perm filename PARSE.SAI[AL,HE]30 blob
sn#463357 filedate 1979-07-30 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00052 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 UPDATES TO PARSE BY MSM
C00011 00003 the AL to S-expression translator AND MSM SWITCHES
C00016 00004 ! statement, operator, sex, require, move definitions
C00022 00005 ! brace, condition_monitor, dimension, misc reserved word definitions
C00024 00006 ! dec_name, declaration names for input and output
C00026 00007 ! operators
C00028 00008 ! reserved_words
C00031 00009 ! init_reserved
C00033 00010 ! predefined constants
C00036 00011 ! predefined macros
C00038 00012 ! compiler switches and control tables
C00041 00013 ! hash, declaration of debugging variables, start of hidden_parse
C00044 00014 ! ---- DECLARATIONS ----
C00050 00015 ! record declarations
C00056 00016 ! other declarations
C00058 00017 ! error, error_recovery, error_reject, print, file_indent
C00074 00018 ! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy
C00082 00019 ! push_source_list,pop_source_list,new_expr_rec
C00084 00020 ! id info processing routines
C00090 00021 ! read
C00095 00022 ! macro handling routine
C00101 00023 ! expand_macro
C00106 00024 ! get_token
C00119 00025
C00123 00026 ! check, inverse, multiply and divide dimensions ! CHECK_EXP_TYPE_DIMENS
C00128 00027 ! check_entry,insert_entry into tables
C00134 00028 ! expression evaluation routines
C00147 00029 ! P_EXP2_BASIC, OPCODE, ERROR HANDLER
C00153 00030 ! exp,bfact,bterm,aexp,term,factor
C00177 00031 ! exp2 starts here, p_exp_basic
C00178 00032 ! P_condition
C00189 00033 ! P_clauses, T_gen
C00203 00034 ! P_statement, F_state, modify_continue, modify_flush
C00208 00035 ! begin_P,end_P, open_paren_P
C00218 00036 ! for_P,case_P,do_P
C00224 00037 ! move_P,affix_P,unfix_P
C00231 00038 ! signal_p, wait_p
C00235 00039 ! dump_P
C00239 00040 ! on_P, reference_P,deproach_P
C00242 00041 ! open_P,center_P,stop_P,enable_P,disable_P
C00245 00042 ! require_P
C00252 00043 ! dimension_P
C00255 00044 ! string_P
C00257 00045 ! abort_P, note_P,comment_P,speed_factor_P,wrist_P,setbase_P
C00261 00046 ! define_P,declare_P,global_P,procedure_P,return_P
C00278 00047 ! P_statement execution starts here
C00289 00048 ! execution starts here, initialization
C00294 00049 ! set up input and output
C00298 00050 ! set up predefined dimensions, constants, macros and variables
C00301 00051 ! PARSE PROGRAM
C00303 00052 ! SWAP TO AL COMPILER
C00305 ENDMK
C⊗;
COMMENT UPDATES TO PARSE BY MSM
10-20-78 indexed frames and events now accepted
10-10-78 f←⊗ + xhat now invalid
9- 8-78 FIXED BUG OF identifier not used when it is actually used in
argument field of procedure
fixed bug of s←1.75 being parsed to s←1.0 because of the way
←← was handled.
8- 4-78 no more I option on error
unused variables now give warning message
7-26-78 no more user comment delimiters and macro delimiters
7-13-78 WRIST,SETFORCE
6-27-78 INT DIV MOD ETC
6- 3-78 IMPLEMENTED ARRAY, PROCEDURE DECLARATIONS AND RELEVANT UPDATE TO
EXP,BFACT, case statement
DO .... UNTIL STATEMENT
5-30-78 IMPLEMENTED DEPROACH(F)←T
5-29-78 IMPLEMENTED LOG,EXP,CONSTRUCT,≡
CASE STATEMENT
5 -15-78 FIXED BUG IN CHECK_DIMENSIONS WHICH CAUSED A RECORD WITH
ALL COEFFICIENTS NON ZERO TO BE NOT TREATED AS NIL_DIMENS
COMPILER SWITCH "N" AND UNKNOWN SWITCH PASSED THROUGH AT ARG'S REQUEST
3 - 7-78 UNIQUE S-EXPRESSION IDENTIFIERS BEGINNING WITH $
3 - 4-78 EXPRESSION PARSER CHANGED, ADDED SIN, COS, ACOS, ASIN, etc
11-24-77 NONRIGIDLY DEFAULT AFFIXMENT CHANGED TO RIGIDLY
NO NULL ADDED
9-15-77 FIXED BUG THAT MAKES INV(A)*B TO (TINVRT (TTMUL A B))
BY ADDING "INV" TO PARSE_SPECIAL
6-29-77 GLOBAL BACKUP TO END OF LATEST END,BEGIN OR SEMI-COLON POSSIBLE
6- 7-77 PREDEFINED MACROS
ADJACENT MACRO BUG FIXED
6- 1-77 CODE FOR NEW FORCE STUFF
5-19-77 UNARY + AND - FINALLY WORK, SIGH
5- 3-77 STRICT DIMENSIONAL CHECKING NOW DEFAULT
3-16-77 ENABLE/DISABLE
MESSAGE END OF EACH BLOCK GIVING LIST OF VARIABLES NOT DEFINED AND
NOT USED
REMOVED PARSESHIT
1- 9-77 MORE MEANINGFUL ERROR MESSAGES
1- 9-77 CAN CORRECT MORE ERRORS
WILL NOT ACCEPT DIMENSIONS ON ANYTHING EXCEPT SCALARS AND VECTORS.
1- 5-77 ACCEPTS STRING DEFINITIONS
12-25-76 CAN CORRECT MINOR ERRORS IN SOURCE CODE IN_LINE
12-23-76 CAN ACCEPT TTY INPUT AS A FILE
12-21-76 ACCEPTS DIMENSIONS ON CONDITION MONITORS
CREATES NEW DECLARATIONS IF UNDECLARED TERM USED IN LHS OF ASSIGNMENT
12-15-76 BAIL CAN BE CALLED IN FROM REQUIRE SWITCHES INSTRUCTIONS
DEFAULT AND ONLY ACCEPTABLE DIMENSIONS OF FRAME IS DISTANCE
TRANS SHOULD BE DIMENSIONLESS
12-14-76 NEW SETUP FOR RESERVED WORD DEFINITIONS, ETC.
ERROR RECOVERY 55, WHEN FILE ASKED FOR DOES NOT EXIST
COMBINATION OF PLUS_R,MINUS_R
COMBINATION OF TMAKE_R, FMAKE_R
12-10-76 WHEN ERROR OF MACRO WITH PARAMETERS ACTUAL PARAMETERS SUBSTITUTED
ACCEPTS ONLY DISTANCE VECTOR ETC NO LONGER VECTOR DISTANCE
REQUIRE BAIL ADDED
12- 7-76 MACRO EXPANSION OF TEXT OK
12- 6-76 REQUIRE COMMENT_DELIMITERS
11-16-76 NEW CHECK_ENTRY AND INSERT_ENTRY PROCEDURES
11-15-76 INSERTION OF STRICT_DIMEN_CHECK SWITCH
ALL PREDEFINED CONSTANTS DECLARED DIMENSIONLESS
11-14-76 DIMENSIONLESS DECLARATION COERCED TO TYPE OF EXPRESSION
XHAT,YHAT,ZHAT MADE DIMENSIONLESS
11-6-76 NEW WAY OF COMPUTING DIMENSIONS
11-2-76 CHANGE LABEL TO STMLAB ON PG 6
11-2-76 CHANGES TO DECLARE_P TO allow default of distance to frames
11-2-76 LN49 PG 24 ADDED TO GIVE DIMENSION OF FRAME AS DISTANCE
11-2-76 ADDED ELSE DIM←0 AFTER SECOND IF STATEMENT TO CURE BUG ON PG 41 DECLARE_P
11-1-76 WOBBLE COMMAND IMPLEMENTED
10-29-76 LOGGING FEATURE IMPLEMENTED
10-27-76 TVSUB AND VSUB IMPLEMENTED
10-18-76 CHANGE STOP BLUE OR YELLOW TO STOP BARM OR YARM;
comment the AL to S-expression translator AND MSM SWITCHES;
Begin "PARSE"
REQUIRE 4096 STRING_PDL; REQUIRE 4096 STRING_SPACE; REQUIRE 2048 SYSTEM_PDL;
require "[][]" delimiters;
define
α =[begin],
β =[end],
! =[comment],
tab ='11,
alt ='175,
lf ='12,
ff ='14,
cr ='15,
space ='40,
dquote ='42,
squote ='47,
rubout ='177,
crlf =[('15&'12)],
ampersand ='46,
id_hasher =32,
array_hasher =16,
procedure_hasher=16,
macro_hasher =16,
metric_hasher =16,
reserved_hasher =256,
RPTR =[RECORD_POINTER],
RCLASS =[RECORD_CLASS],
RANY =[RECORD_POINTER(ANY_CLASS)],
preload_array(name, defs, type, first, len)=[
preset_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
! if /nB is set in the command line then assume he wants a debugging parser;
define id_type_table=0,
macro_type_table = 1,
macro_in_macro_type_table = 2,
dimension_type_table = 3 ,
array_type_table = 4,
procedure_type_table = 5;
require "<><>" delimiters;
ifc ¬declaration(debug_compile) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), space, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define debug_compile=false;
elsec define debug_compile=true;
endc
endc
define
decipher_compiletime(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+6 for 21];
"a">;
require unstack_delimiters;
require ifc ¬debug_compile
thenc " NON-" elsec " " endc & "DEBUGGING VERSION " message;
ifc debug_compile thenc EXTERNAL PROCEDURE BAIL;
REQUIRE "LA" ERROR_MODES; ! to compile and go home when system busy;
endc
define
indices(name, postfix)=[
redefine xxcount=0;
redefine xx(xxarg)=[
redefine xxtemp=[define xxarg] & [postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name];
! ID postfix conventions
_VALUE AL data types
_RES reserved word types
_beg reserved word group begin
_end reserved word group end
_R REDUCE action routines
_P PARSE action routines
_TOKEN scanner token types
_CM condition monitors
_X indices of various sorts
_METRIC dimensional analysis non-sense
_DIMEN how to combine various matrix operands
_TYPE to decide which table to insert into
;
! **********; require "SNAILR[AL,HE]" source_file; ! **********;
INTEGER PROCEDURE ___TIME;
BEGIN
INTEGER __T;
quick_code
setz '13, ;
calli '13,'27 ;
movem '13,__T ;
end;
RETURN(__T);
END;
! ************ MSM SWITCHES *************;
DEFINE DEFIN_PRINT_SWITCH = FALSE;
DEFINE DUP_FILE = true;
DEFINE full_set = true;
! statement, operator, sex, require, move definitions;
redefine xx(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine xx_temp="define " & "str" & "_RES=reserved_X_count";
xx_temp;];
redefine yy(str,str2)=[];
redefine zz(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine zz_temp="define " & "str" & "_RES=reserved_X_count";
zz_temp;];
define statement_definitions=[
xx(BEGIN)
yy(COBEGIN)
xx(END)
yy(COEND)
yy([;])
zz(OPEN_PAREN)
yy([(])
zz(DECLARE)
yy(SCALAR, scalar_value)
yy(VECTOR, vector_value)
yy(ROT, rot_value)
yy(FRAME, frame_value)
yy(PLANE, plane_value)
yy(TRANS, trans_value)
yy(EVENT, event_value)
yy(ATOM, atom_value)
yy(WORLD, world_value)
yy(LABEL, label_value)
! xx(GLOBAL) ;
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(DO)
xx(CASE)
xx(RETURN)
xx(MOVE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
! xx(WHEN) ;
xx(DUMP)
! xx(ASSERT)
yy(DENY) ;
xx(ON)
yy(DEFER)
! xx(REFERENCE) ;
xx(OPEN)
yy(CLOSE)
xx(CENTER)
xx(STOP)
xx(SPEED_FACTOR)
xx(DEPROACH)
xx(PROCEDURE)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
! xx(STRING)
yy(NEW_STRING)
yy(OLD_STRING) ;
xx(COMMENT)
xx(ABORT)
yy(PRINT)
yy(PAUSE)
yy(PROMPT)
xx(NOTE)
yy(NOTE1)
yy(NOTE2)
xx(SETBASE)
xx(WRIST)
xx(ENABLE)
xx(DISABLE)
];
define operator_classes=[
zz(COMMA)
yy([,])
xx(EQV, eqv_x)
yy([≡], eqv_X)
xx(OR, or_X)
yy([∨], or_X)
yy([⊗], xor_X)
yy(XOR, xor_X)
xx(AND, and_X)
yy([∧], and_X)
xx(NOT, not_X)
yy([¬], not_X)
zz(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
zz(ABS)
yy([|], sabs_X)
! yy(VVVTRANS);
zz(ADD)
yy([+], plus_X)
yy([-], minus_X)
zz(MULT)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy(MAX, max_x)
yy(MIN, min_x)
yy(DIV, div_x)
yy(MOD, mod_X)
! yy(VVROT, vvrot_X) ;
zz(WRT)
yy(WRT, wrt_X)
yy(→, →_X)
yy([↑], stos_X)
zz(FUNC)
! yy([#],, nomv_X);
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
yy(INT, int_X)
yy(CONSTRUCT, construct_X)
yy(SQRT, sqrt_x)
yy(SIN, sin_x)
yy(COS, cos_x)
yy(TAN, tan_x)
yy(ASIN, asin_x)
yy(ACOS, acos_x)
yy(ATAN2, atan2_x)
yy(LOG, log_x)
yy(EXP, exp_X)
! zz(SCALAR)
yy(ANGLE, angle_X);
zz(CLOSE_PAREN)
yy([)])
];
define require_definitions=[
xx(SOURCE_FILE)
xx(MESSAGE)
xx(ERROR_MODES)
xx(COMPILER_SWITCHES)
xx(BAIL)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(APPROACH)
yy(ARRIVAL)
yy(DEPARTURE)
xx(WOBBLE)
xx(NO_NULLING)
xx(RTMOVE)
xx(NULLING)
xx(DIRECTLY)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
sex_RES =-2,
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
! brace, condition_monitor, dimension, misc reserved word definitions;
define brace_definitions=[
zz(BRACE)
yy([}])
yy([{])
];
define cm_definitions=[
zz(cm)
qq(nil)
yy(FORCE, force_cm)
yy(TORQUE, torque_cm)
yy(DURATION, duration_cm)
yy(TEMPERATURE)
yy(SQUEEZE)
];
define metric_definitions=[
zz(METRIC)
qq(nil)
yy(DISTANCE, distance_METRIC)
yy(TIME, time_METRIC)
! yy(MASS, mass_METRIC) ;
yy(ANGLE, angle_METRIC)
yy(FORCE, force_metric)
];
DEFINE MISC_DEFINITIONS=[
zz(MISC)
yy([?])
yy(ABS)
yy(TO)
yy(TRACING)
yy(WHERE)
yy(THEN)
yy(FORM)
yy(AT)
yy(BY)
yy(CHANGING)
yy(ALSO)
yy(DONT)
yy(ONLY)
yy(QUERY)
yy(RIGIDLY)
yy(NONRIGIDLY)
yy(STEP)
yy(INSCALAR)
yy(UNTIL)
yy(ELSE)
! yy(⊗) ;
];
redefine zz(str)=[];
redefine qq(str)=[
redefine qq_temp=[xx(str)];
qq_temp;];
redefine yy(str,str2)=[
redefine yy_temp=[xx(str)];
yy_temp;];
indices(metric_definitions, _METRIC);
define
metric_max =xxcount-1;
indices(cm_definitions, _CM);
EVALdefine basic_dimensions=[
redefine zz(str,str2)=[];
redefine qq(str,str2)=[];
redefine yy(str,str2)=[xx(str)];
metric_definitions
];
! dec_name, declaration names for input and output;
! don't juggle the order of these definitions, because the parse will cease to
function;
define dec_name_definitions=[
xx(SCALAR, $SVAR)
xx(VECTOR, $VVAR)
xx(ROT, $RVAR)
xx(FRAME, $FVAR)
xx(PLANE, $PVAR)
xx(TRANS, $TVAR)
xx(EVENT, $EVAR)
xx(ATOM, $ATOM)
xx(WORLD, $WVAR)
! xx(CM_LABEL, $OMNLAB)
xx(CLC_LABEL, $CLCLAB)
xx(CH_LABEL, $CHGLAB)
xx(LABEL, $STMLAB) ;
xx(LABEL, $LAB)
];
! data types;
DEFINE
string_VALUE =-2,
form_VALUE =-1,
boole_VALUE =0; ! others follow directly, but see later;
define
dec_name_count=0;
redefine xx(in, out)=[
redefine dec_name_count=dec_name_count+1;
redefine xx_temp="define in" & "_VALUE=" & cvms(dec_name_count);
xx_temp;];
dec_name_definitions;
redefine boole_value=scalar_value;
define frame_exp_VALUE=trans_VALUE; ! COERCION DICTATES THAT THESE BE THE SAME;
redefine xx(in, out)=["out",];
preload_array(
dec_name, dec_name_definitions, string, 1, dec_name_count);
! operators;
define operator_definitions=[
XX(NOT)
XX(EQV)
XX(AND)
XX(OR)
XX(XOR)
XX(SEQ)
XX(SNE)
XX(SGT)
XX(SLT)
XX(SGE)
XX(SLE)
XX(UVECT)
XX(AXIS)
XX(POS)
XX(ORIENT)
XX(TMAKE)
XX(VMAKE)
XX(FMAKE)
XX(VVTRANS)
! XX(SNEG) ;
XX(RINV)
XX(SABS)
XX([+], PLUS)
XX([-], MINUS)
XX([*], TIMES)
XX(MAX)
XX(MIN)
XX(DIV)
XX(MOD)
XX(INT)
XX(WRT)
XX(ROT)
XX(→)
! XX(ANGLE);
XX(VDOT)
XX(VCROSS)
XX(CONSTRUCT)
XX(SQRT)
XX(SIN)
XX(COS)
XX(TAN)
XX(ASIN)
XX(ACOS)
XX(ATAN2)
XX(LOG)
XX(EXP)
XX(VVROT)
XX(SDIV)
XX(STOS)
XX(NOMV)
];
define
op_count=0;
redefine xx(str1, str2)=[
redefine op_count=op_count+1;
ifc "str2"=null
thenc redefine xxtemp=[define str1] & "_X=op_count";
elsec redefine xxtemp=[define str2] & "_X=op_count";
endc
xxtemp;];
operator_definitions;
redefine xx(str1,str2) = [ "str1", ];
preload_array(OPERATORS, OPERATOR_DEFINITIONS, STRING, 1, OP_COUNT);
! reserved_words;
define reserved_definitions=[
brace_definitions
cm_definitions
statement_definitions
operator_classes
require_definitions
move_definitions
misc_definitions
];
define
reserved_count=0;
redefine zz(name)= [];
redefine qq(name)= [];
redefine xx(name)=[
redefine reserved_count=reserved_count+1;];
redefine yy(name, special)=[
redefine reserved_count=reserved_count+1;];
reserved_definitions;
redefine xx(name)=["name",];
redefine yy(name,special)=["name",];
preload_array(
reserved_words, reserved_definitions, string, 1, reserved_count);
redefine zz(name)=[
redefine class=["name"];
];
redefine xx(name)=[
redefine xxtemp=[name] & "_RES";
redefine class=["name"];
xxtemp,];
redefine yy(name,special)=[
redefine yytemp= class &"_RES";
yytemp,];
preload_array(
reserved_class, reserved_definitions, integer, 1, reserved_count);
redefine xx(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
redefine yy(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
preload_array(
reserved_special, reserved_definitions, integer, 1, reserved_count);
whilec [reserved_count > 9*reserved_hasher/10] doc
[require "
RESERVED TABLE NOT BIG ENOUGH, WILL DOUBLE IT.
" message ;
redefine reserved_hasher=reserved_hasher+reserved_hasher;]
endc
string array
reserved[0:reserved_hasher-1];
integer array
com_type[0:reserved_hasher-1];
! init_reserved;
forward SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
procedure init_reserved;
α string s; integer i, k;
boolean procedure find_sym(string s; reference integer k);
α string probe;
k ← hash(s, reserved_hasher);
while (probe ← reserved[k])≠null do
if equ(s, probe) then return(true) else k ← (k+1) mod reserved_hasher;
return(false);
β;
arrclr(reserved); arrclr(com_type);
for i ← 1 step 1 until reserved_count do
if find_sym(reserved_words[i], k)
then α if reserved_class[i] ≠ SEX_RES then
outstr(reserved_words[i] & " doubly defined!" & crlf);
β
else
α
reserved[k] ← reserved_words[i];
com_type[k] ← reserved_class[i]+reserved_special[i]*reserved_hasher;
β;
require "<><>" delimiters;
s ← decipher_compiletime();
require unstack_delimiters;
outstr("COMPILED "&s&crlf&crlf);
β;
require init_reserved initialization [0];
! predefined constants;
define constant_definitions=[
XX(GARB_ID, scalar, nil) ! do not move this entry;
XX(PI, scalar, nil)
XX(π, scalar,nil)
XX(INCH, scalar, distance)
XX(INCHES, scalar, distance)
XX(CM, scalar, distance)
XX(SEC, scalar, time)
XX(SECONDS, scalar, time)
! XX(GM_MASS, scalar, mass) ;
XX(DEG, scalar, angle)
XX(DEGREES, scalar, angle)
XX(RADIANS, scalar, angle)
XX(GM, scalar, force)
XX(OZ, scalar, force)
XX(LBS, scalar, force)
XX(OUNCES, scalar, force)
XX(XHAT, vector, nil)
XX(YHAT, vector, nil)
XX(ZHAT, vector, nil)
XX(NILVECT, vector, nil)
XX(NILROTN, rot, angle)
XX(NILTRANS, trans, distance)
XX(STATION, trans, distance)
XX(YPARK, trans, distance)
XX(BPARK, trans, distance)
XX(YARM, trans, distance)
XX(BARM, trans, distance)
XX(YHAND, scalar, distance)
XX(BHAND, scalar, distance)
XX(TRUE, boole, nil)
XX(FALSE, boole, nil)
XX(CRLF, string, nil)
];
define
const_count = 0;
redefine xx(str, i1, i2)=[redefine const_count = const_count+1;];
constant_definitions;
define zap_const(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str, i1, i2)=[arg,];
elsec redefine xx(str, i1, i2)=[arg] & [postfix,];
endc
preload_array(name, constant_definitions, type, 1, const_count)];
zap_const(
preconst, string, "str");
zap_const(
preconst_type, integer, i1, _VALUE);
zap_const(
pre_dimens, integer, i2, _METRIC);
! predefined macros;
define macro_definitions=[
! XX(DIRECTLY, [ WITH APPROACH = NILDEPROACH WITH DEPARTURE = NILDEPROACH]);
XX(CAUTIOUS, [ SPEED_FACTOR ← 2.0])
XX(SLOW, [ SPEED_FACTOR ← 3.0])
XX(CAUTIOUSLY, [ WITH SPEED_FACTOR = 2.0])
XX(SLOWLY, [ WITH SPEED_FACTOR = 3.0])
XX(SECOND, [ SECONDS ])
XX(DEGREE, [ DEGREES ])
XX(RADIAN, [ RADIANS ])
XX(LB, [ LBS ])
XX(OUNCE, [ OUNCES ])
XX(NILVEC, [ NILVECT ])
XX(NILVECTOR, [ NILVECT ])
XX(NILROT, [ NILROTN ])
XX(SETUP_BARMF, [ FRAME BARMF;
AFFIX BARMF TO BARM AT TRANS(ROT(XHAT,180*DEGREES),NILVECT*inches) RIGIDLY; ])
XX(SETUP_BGRASP, [ FRAME BGRASP;
AFFIX BGRASP TO BARM AT TRANS(ROT(XHAT,180*DEGREES),NILVECT*inches) RIGIDLY; ])
XX(INITIALIZE, [ MOVE BARM TO BPARK WITH DURATION = 3*SECONDS;
OPEN BHAND TO 3.0*INCHES; ])
XX(NO_NULL, [ NO_NULLING ])
XX(APPROXIMATELY, [ WITH NO_NULLING ])
XX(PRECISELY, [ WITH NULLING ])
];
! compiler switches and control tables;
! As the AL compile time system runs, several intermediate files are created
and destroyed. The default extensions of these files are listed below.
.AL user the ALGOL like AL source language
.LOG user file of errors detected by the PARSER
.SEX AL s-expression version of AL source code
.ALP (.AL0) ALC pseudo code
.ALT (.AL1) ALC trajectory file
.ALV (.AL2) ALC constants and variable definitions for pseudo code
.ALS (.AL3) ALC symbol table usable by the PDP-11 runtime system
.ALL ALC hybrid s-expression/real AL listing
.LST PALX PDP-11 assembly code listing
.BIN PALX PDP-11 binary file loaded by 11TTY
.DMP 11TTY PDP-11 core image
;
! compiler switches;
define compiler_switches=[
xx(K, false) ! keep extraneous intermediate files: .ALP, .ALV, .ALT;
xx(S, false) ! inhibit the deletion of the .SEX file;
xx(L, false) ! generate a PALX assembly listing;
xx(N, false) ! swap to ALCNEW instead of ALC;
xx(B, false) ! run BAIL immediately after scanning the command line;
xx(E, false) ! load the .BIN file into the PDP-11;
];
indices(compiler_switches, _X);
define
switch_max =xxcount-1;
redefine xx(name, default)=["name",]; preload_array(
switch_name, compiler_switches, string, 0, switch_max+1);
redefine xx(name, default)=[default,]; preload_array(
switch_default, compiler_switches, boolean, 0, switch_max+1);
boolean array
switch_setting[0:switch_max];
procedure preset_switches;
α integer i;
for i ← 0 step 1 until switch_max do switch_setting[i] ← switch_default[i];
β;
require preset_switches initialization[0];
! hash, declaration of debugging variables, start of hidden_parse;
SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
α INTEGER I,TOT,C;
C←I←1; TOT←0;
WHILE I≠0 DO TOT←TOT+(C←C+1)*(I←LOP(S));
RETURN(TOT MOD MAX);
β;
ifc debug_compile thenc ! some variables that can be used for debugging;
require "BREAK.HDR[1,PJ]" source_file;
RPTR(any_class)
__r0, __r1, __r2, __r3, __r4, __r5, __r6, __r7, __r8, __r9;
string
__s0, __s1, __s2, __s3, __s4, __s5, __s6, __s7, __s8, __s9;
integer
__i0, __i1, __i2, __i3, __i4, __i5, __i6, __i7, __i8, __i9;
real
__x0, __x1, __x2, __x3, __x4, __x5, __x6, __x7, __x8, __x9;
procedure debug_init;
α
__r0 ← __r1 ← __r2 ← __r3 ← __r4 ← __r5 ← __r6 ← __r7 ← __r8 ← __r9 ← null_record;
__s0 ← __s1 ← __s2 ← __s3 ← __s4 ← __s5 ← __s6 ← __s7 ← __s8 ← __s9 ← null;
__i0 ← __i1 ← __i2 ← __i3 ← __i4 ← __i5 ← __i6 ← __i7 ← __i8 ← __i9 ← 0;
__x0 ← __x1 ← __x2 ← __x3 ← __x4 ← __x5 ← __x6 ← __x7 ← __x8 ← __x9 ← 0.0;
β;
require debug_init initialization[0];
endc
! The following (making all of parse a recursive procedure) is a hack to get the
restart option to work properly. As soon as a better way is found of
making sure everything gets reinitialized properly, this should be taken
out;
IFC FALSE THENC
recursive procedure hidden_parse;
α "hidden_parse"
ENDC;
! ---- DECLARATIONS ----;
external integer
rpgsw;
RPTR(file)
AL_file, ! AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file, ! ALC listing file;
LOG_file, ! LOG listing file;
NEW_file,
PRESENT_file; ! Present file;
BOOLEAN
DISK, ! TRUE IF INPUT IS COMING FROM DISK;
AUTO_PROCEED, ! TRUE IF AUTO_PROCEED SWITCH IS ON FOR ERROR RECOVERY;
IGNORE_CORRECTION, ! TRUE IF DONT WANT TO MODIFY BUT JUST CONTINUE;
LOGGING, ! TRUE IF LOGGING WANTED;
COMPILE_LOGGING, ! TRUE IF LOGGING WANTED THROUGH REQUIRE STATEMENT;
now_top_file,
LOG_FILE_OPEN,
STRICT_DIMEN_CHECK;
ifc dup_file thenc
BOOLEAN
WANT_DUP_FILE; ! TRUE IF WANT CORRRECTED FILE;
endc
STRING
cmd_line,
INFILE,
OUTFILE, ! INPUT,OUTPUT & LOG FILES;
NEWFILE,
LOGFILE;
INTEGER
CHANIN,
CHANOUT,
CHANNEW,
CHANTTYO,
CHANLOG;
STRING
OUTSTRING,
PARSED_STRING,
INSTRING, ! INPUT STRING;
TABLE1; ! BREAK TABLES;
! GET_TOKEN VARIABLES;
REAL
REALNUM;
INTEGER
TYPE_OF_RES_WORD, ! TYPE PULLED OFF OF COM_TYPE;
SPECIAL_INFO, ! INFO PASSED FROM SCANNER TO PARSER - DEPENDS ON TYPE;
ID_TYPE,
ARRAY_TYPE,
PROCEDURE_TYPE,
BLOCK_LEVEL_OF_DEFN,
RESERVED_TOKEN_PTR,
TYPE_OF_TOKEN;
define
special_token =-1,
undeclared_token=0,
id_token =1,
numeric_token =2,
string_token =3,
macro_token =4,
MACRO_BODY_TOKEN=5,
metric_token =6,
reserved_token =7,
array_token =8,
procedure_token =9;
STRING PROCEDURE TOKEN_TYPE_TRANSFORM;
α string s1;
s1← CASE TYPE_OF_TOKEN OF ( "undeclared","id","numeric",
"string","macro","macro_body","metric","reserved","array","procedure");
return(s1&"_type");
β;
STRING PROCEDURE ID_TYPE_TRANSFORM;
α string s1;
s1← CASE (ID_TYPE + 2 )OF ("string","form","boole","scalar",
"vector","rot","frame","plane","trans","event","atom",
"world","on_label","calculator_label",
"changer_label","statement_label");
return(s1&"_type");
β;
STRING
TOKEN,TOKEN2,
TOKEN_FRONT;
RPTR(ANY_CLASS)
TOKEN_PTR;
! END GET_TOKEN VARIABLES;
integer
word_R_break, ! break tables;
non_blank_break,
word_S_break,
close_brace_break,
non_digit_break,
quote_break,
macro_delimiter_break,
semicolon_A_break,
cr_break,
paren_cr_break,
lf_ff_break,
semicolon_R_break,
knvrt_break,
omit_break,
tty_input_break;
STRING
CURRENT_FRAME; ! TOKEN OF THE CURRENT FRAME - DEFAULT SET TO "YARM";
INTEGER
SPACING, ! SPACING FOR OUTPUT;
SAVSPACING;
BOOLEAN
REJECT, ! TRUE WHEN THE LAST TOKEN IS REJECTED BY THE CALLING PROC;
switch_file,END_FLAG;
INTEGER
DEC_NUM, ! THE NUMBER OF DECLARATIONS IN THE CURRENT BLOCK;
ARRAY_DEC_NUM,
PROCEDURE_DEC_NUM,
MACRO_DEC_NUM, ! THE NUMBER OF MACROS IN CURRENT BLOCK;
DIMEN_DEC_NUM; ! THE NUMBER OF DIMENSIONS IN THE CURRENT BLOCK;
STRING
OUTEXPR; ! FOR THE CONSTRUCTION OF THE STRING FOR EXPRESSIONS;
STRING
OPEN_BRACE;
INTEGER
CHECK_TYPE_VAR; ! RETURNS TYPE OF ID FROM CHECK_ENTRY;
STRING
MACRO_STRING;
! ERROR VARIABLES;
BOOLEAN
INSIDE_MACRO_DEFINITION,
INSIDE_DECLARE_P,
INSIDE_CONDITION_MONITOR,
INSIDE_STRING_DECLARATION,
INITIALIZE, ! INITIALIZATION PROCESS;
GLOBAL_BACKUP,
patch_code,
GLOBAL_MODIFIED,
PROMPT_FOR_MODIFIABLE_ERROR_ONLY;
INTEGER
NUM_OF_ERRORS,
INSIDE_STATEMENT,
NUM_OF_ERRORS_FLUSHED,
NUM_OF_ERRORS_MODIFIED;
! END ERROR VARIABLES;
INTEGER
RUNTIME;
! record declarations;
RCLASS
PARAM_LIST(
STRING
ID,
USER_ID;
RPTR(PARAM_LIST)
NEXT
);
RCLASS
MACRO_LIST(
STRING
VALUE, ! ACTUAL MACRO body;
ID;
INTEGER
NUM; ! NUMBER OF PARAMETERS;
RPTR(MACRO_LIST)
NEXT, ! POINTS TO NEXT MACRO WHICH HASHES TO THE SAME ENTRY;
LAST, ! BACK POINTER IN THE SAME LIST;
LINK; ! USED ONLY FOR PARAMETER EXPANSION, POINTS TO THE
PARAMETER DEFINED JUST BEFORE THIS ONE;
RPTR(PARAM_LIST)
PARAMS;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(MACRO_LIST)
TOP_PARAM,
current_macro,
TOP_MACRO,
CUR_MACRO;
RPTR(MACRO_LIST) ARRAY
MACRO_TABLE[0:macro_hasher];
RCLASS
MACRO_STACK(
RPTR(MACRO_LIST)
LIST_PTR;
RPTR(MACRO_STACK)
STACK_LINK
);
RPTR(MACRO_STACK)
MACRO_STACK_TOP,
MACRO_ST2;
RCLASS
DIMENS_EXPONENT(
STRING
NAME;
INTEGER
DISTANCE,
TIME, ! GIVES EXPONENTS OF VARIOUS COEFFICIENTS;
MASS,
ANGLE,
FORCE;
RPTR(DIMENS_EXPONENT)
NEXT,
LAST;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(DIMENS_EXPONENT)
NIL_DIMENS,
DISTANCE_DIMENS,
TIME_DIMENS,
! MASS_DIMENS;
ANGLE_DIMENS,
FORCE_DIMENS,
TORQUE_DIMENS,
VELOCITY_DIMENS,
ANGULAR_VELOCITY_DIMENS,
TOP_DIMENS, ! POINTS TO TOP MACRO IN THIS BLOCK;
EXP_DIMENS;
RPTR(DIMENS_EXPONENT) ARRAY
DIMENS_TABLE[0:metric_hasher],
D_TABLE[0:metric_max];
RCLASS
ID_LIST(
STRING
NAME,
BODY;
INTEGER
FLAGS,
TYPE;
RPTR(ID_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(ID_LIST) ARRAY
SYMBOL_TABLE[0:id_hasher];
RPTR(ID_LIST)
TOP_ID;
RCLASS
array_LIST(
STRING
NAME;
INTEGER
FLAGS,
#DIMENS,
TYPE;
RPTR(array_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(array_LIST) ARRAY
ARRAY_SYMBOL_TABLE[0:array_hasher];
RPTR(array_LIST)
TOP_array;
RCLASS
procedure_LIST(
STRING
NAME;
INTEGER
FLAGS,
#ARGS,
TYPE;
RPTR(PROCEDURE_LIST)
NEXT, ! POINTS TO NEXT PROCEDURE WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE PROCEDURE DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
RPTR(id_list,array_list) ARRAY
ARGS;
INTEGER ARRAY
isid,ARGMODE;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(procedure_LIST) ARRAY
procedure_SYMBOL_TABLE[0:procedure_hasher];
RPTR(procedure_LIST)
TOP_procedure;
RCLASS
SOURCE_LIST(
INTEGER
CHAN, ! i/o CHANNEL NUMBER OF input, -1 if from macro;
NUM, ! NUMBER OF PARAMETERS IN THE CURRENT MACRO;
PN,
LN; ! PAGE AND LINE NUMBER OF THE PUSHED FILE;
STRING
CUR_STRING, ! curline WHEN PUSHED;
CUR_STRINGR, ! curliner WHEN PUSHED;
FILE_NAME, ! NAME OF THE INPUT FILE WHEN PUSHED;
P_STRING,
MACRO_STRING;
RPTR(SOURCE_LIST)
NEXT;
RPTR(MACRO_STACK)
MACRO_STACK_TOP;
RPTR(MACRO_LIST)
CUR_MACRO;
RPTR(FILE)
COPY_FILE,
FILE_PTR;
INTEGER
CHANTTYO,
CHANNEW
);
RPTR(SOURCE_LIST)
TOP_SOURCE;
! other declarations;
INTEGER
EXP_TYPE; ! TYPE OF EXPRESSION FOUND BY P_EXP;
BOOLEAN
PLAN_STATEMENT; ! TRUE IF CURRENT STATMENT IS PREFIXED BY PLAN;
STRING
CHANGER_HEAD; ! NON NULL IF PARSING A STATEMENT INSDIDE A CHANGER;
INTEGER
T_COUNT, ! COUNTER FOR PRODUCING UNIQUE ID'S;
S_COUNT; ! COUNTER FOR PRODUCING UNIQUE SCALARS;
BOOLEAN
NO_OP_SO_FAR,
OP_EXPECTED; ! TRUE WHEN P_EXP EXPECTS AN OPERATION;
INTEGER
DELIMITER_1,
DELIMITER_2; ! HEAD AND TAIL DELIMITER OF macro bodies;
INTEGER
MAC_NUM; ! NUMBER OF PARAMS IN THE CURRENT MACRO EXPANSION;
INTEGER
BLOCK_LEVEL;
! GARBAGE DECLARATIONS (VERY LOCAL);
BOOLEAN
T,
EOF;
INTEGER
COUNT,
I,
N,
BRCHAR;
STRING
GARB;
INTEGER
LINENUM,
PAGENUM,
SOSNUM,
typed_page_num, ! on tty;
sourcelvl;
STRING
CURLINER,
CURLINE;
! error, error_recovery, error_reject, print, file_indent;
FORWARD RECURSIVE PROCEDURE P_STATEMENT;
FORWARD RECURSIVE PROCEDURE GET_TOKEN(boolean noexpand(false));
FORWARD PROCEDURE OPEN_LOGGING_FILE;
forward RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
forward RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S;
INTEGER TABLE_TYPE; RPTR(ANY_CLASS) RR1(NULL_RECORD));
forward boolean procedure got_output(RPTR(file) F; string ext(null));
RPTR(ANY_CLASS) PROCEDURE ERROR_basic(INTEGER I;STRING S);
! I don't understand the error number stuff. All errors numbered 200
have been added by me and can be arbitrarily reassigned.
PJ 8/30/76
I should have made this comment earlier, but didn't. The error
number is meaningless to the user. It is even useful to the
people modifying PARSE, to the extent that it helps to figure
out where the error is coming in from in the source program.
Actually, the error numbers should be used to indicate on
which page or line the code is. Numbering may be useful
for the user if we want to have a small parser, and store
error messages on a disk file.
MSM 3/5/78 ;
α INTEGER L1,L2; BOOLEAN PROCEED; INTEGER COMMAND_CHAR; BOOLEAN TERSE;
RPTR(ANY_CLASS) PROCEDURE ERROR_RECOVERY(INTEGER I);
IF I=13 THEN α RPTR(ID_LIST)D1;
OUTSTR(CRLF& "Continue will declare it internally");
D1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[D1]←TRANS_VALUE;
ID_LIST:BLOCK_LEVEL_OF_DEFN[D1]←BLOCK_LEVEL;
RETURN(D1);
β
ELSE
IF I=55 THEN α string s; s←null;
WHILE LENGTH(S)=0 AND ¬AUTO_PROCEED DO α
OUTSTR(CRLF& "Type in correct file"&crlf& "*");
s←inchwl; PROCEED←TRUE;
if length(s)≠0 then infile←s;
β;
RETURN(NULL_RECORD);
β
ELSE
RETURN(NULL_RECORD);
RPTR(ANY_CLASS) C1;
string source_pos;
STRING LINE,LINER;
source_pos←"File "& INFILE& ", Page "& CVS(PAGENUM+1)& ", Line "& CVS(LINENUM);
LINE←CURLINE; LINER←CURLINER;
IF CHANIN≤-1 THEN α ! SUBSTITUTE DUMMY PARAMETERS OF MACRO FOR REAL THING;
INTEGER I1,PARAM_COUNT;
source_pos← "At "&source_pos&crlf&"inside Macro "¯o_list:id[current_macro];
if liner=space then liner←liner[2 to ∞];
IF (PARAM_COUNT←SOURCE_LIST:NUM[TOP_SOURCE]) > 0
THEN α
string array param_id,param_arg[1:param_count];
RPTR(param_list) param_ptr;
integer l1,l2,temp;
string t;
string procedure subst(string old_string);
α string t,t1,old;
integer brchar,i1;
old←old_string;
t←scan(old,temp,brchar);
while brchar≠0 do
α t1←old[1 to l1];
old←old[l2 to ∞];
for i1←1 step 1 until param_count do
if equ(t1,param_arg[i1])
then t←t¶m_id[i1];
t←t&scan(old,temp,brchar);
β;
return(t);
β;
param_ptr←macro_list:params[current_macro];
source_pos←source_pos&"(";
for i1←1 step 1 until param_count do
α param_arg[i1]←param_list:id[param_ptr];
param_id[i1]←param_list:user_id[param_ptr];
param_ptr←param_list:next[param_ptr];
source_pos←source_pos¶m_id[i1]&",";
β;
l1←length(source_pos);
source_pos←source_pos[1 to l1-1]&")"&crlf;
l2←(l1←length(param_arg[1]))+1;
t←param_arg[1][1 for 1];
setbreak(temp←getbreak,t,null,"INR");
line←subst(line);
liner←subst(liner);
RELBREAK(TEMP);
β;
β;
WHILE EQU(LINE[1 TO 1], lf) DO GARB←LOP(LINE);
L1←LENGTH(LINER); L2←LENGTH(LINE)-L1; PROCEED←AUTO_PROCEED;
IF ¬PROMPT_FOR_MODIFIABLE_ERROR_ONLY OR global_backup
then α
IF global_backup THEN PROCEED←FALSE;
ifc debug_compile thenc
OUTSTR(crlf & "ERROR TYPE " & CVS(I));
endc
IF I<0 THEN OUTSTR(crlf &"WARNING: ") ELSE OUTSTR(crlf);
OUTSTR(S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
β
ELSE IF PROMPT_FOR_MODIFIABLE_ERROR_ONLY THEN PROCEED←TRUE;
C1←ERROR_RECOVERY(I);
IF ¬LOGGING THEN IF COMPILE_LOGGING THEN OPEN_LOGGING_FILE;
IF LOGGING THEN
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
IF IGNORE_CORRECTION THEN PROCEED←TRUE;
IF I<0 THEN PROCEED←TRUE;
WHILE ¬PROCEED DO
α
CLRBUF; OUTSTR("$"); DO COMMAND_CHAR←INCHRS UNTIL COMMAND_CHAR<0;
COMMAND_CHAR←INCHRW;
CASE COMMAND_CHAR OF
α
["b"] ["B"] α
OUTSTR("ail" & crlf);
IFC debug_compile
THENC BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
[cr] α CLRBUF; PROCEED←TRUE; β;
["c"] ["C"] α OUTSTR("ontinue with default recovery"); PROCEED←TRUE; β;
[lf] α PROCEED←TRUE; AUTO_PROCEED←TRUE; β;
["a"] ["A"] α OUTSTR("utomatic continuation");
IF LOGGING THEN OUTSTR(" and logging");
OUTSTR(".");
PROCEED←TRUE; AUTO_PROCEED←TRUE; IGNORE_CORRECTION←TRUE;
β;
["e"] ["E"] α OUTSTR("dit" & crlf);
CLOSO(CHANLOG);CLOSO(CHANOUT);
EDFILE(INFILE,LINENUM,PAGENUM+1,0);
β;
IFC FALSE THENC
["I"] ["i"] α OUTSTR("gnore trying to modify"&CRLF);
PROCEED←TRUE; IGNORE_CORRECTION←TRUE;
β;
ENDC
["r"] ["R"] α
OUTSTR("estart"); CURLINE←CURLINER←null;
USERERR(0,1,NULL,"S"); ! THIS IS A HACK AND SHOULD BE CHANGED
AS SOON AS POSSIBLE;
β;
["x"] ["X"] α OUTSTR("it" & crlf);
USERERR(0,1,NULL,"X"); ! DITTO ABOVE COMMENT;
β;
["t"] ["T"] α OUTSTR("erse" & crlf); TERSE←TRUE; β;
["v"] ["V"] α OUTSTR("erbose" & crlf); TERSE←FALSE; β;
["p"] ["P"] IF PATCH_CODE THEN
α
OUTSTR("atch source code; modify following line"&CRLF);
CLRBUF;
LODED(LINER);
CURLINER←INCHWL;
CURLINE←LINE[1 TO L2] & CURLINER;
PATCH_CODE←FALSE;
PROCEED←TRUE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
β
ELSE OUTSTR("atch - ***** sorry, non-patchable error *****"&CRLF);
["m"] ["M"] IF GLOBAL_BACKUP THEN
α STRING S1,S2;
OUTSTR("odify the following" & CRLF);
PARSED_STRING←PARSED_STRING&CURLINER;s2←null;
WHILE ¬EQU(PARSED_STRING,NULL)
DO α CLRBUF;
S1←SCAN(PARSED_STRING,LF_FF_BREAK,BRCHAR);
IF S1[1 FOR 1]=cr or s1[1 for 1] = LF
THEN α s2←s1; S1←scan(parsed_string, lf_ff_break,brchar);β;
IF LENGTH(S1)≠0 THEN α LODED(S1); S1←INCHWL; β;
S2←S2&S1&CRLF;
β;
CURLINE←CURLINER←S2;
OUTSTRING←PARSED_STRING←NULL;
GLOBAL_MODIFIED←PROCEED←TRUE;
GLOBAL_BACKUP←FALSE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
reject←false;
β
ELSE OUTSTR("Sorry can't do backup");
["?"] IF ¬TERSE THEN
α
OUTSTR("Reply [CR] or ""C"" to continue," & crlf &
"[LF] or ""A"" to continue automatically," & crlf &
"""I"" to ignore trying to modify," & crlf &
"""E"" to edit source file," & crlf &
"""R"" to restart," & crlf &
"""T"" for terse," & crlf &
"""V"" for verbose," & crlf &
"""X"" to exit");
IFC DEBUG_COMPILE THENC OUTSTR("," & crlf & """B"" to load Bail"); ENDC
IF ¬LOGGING THEN OUTSTR("," & crlf & """L"" for logging");
IF GLOBAL_BACKUP THEN OUTSTR("," & crlf & """M"" for modifying source code");
OUTSTR("." & crlf);
β
ELSE OUTSTR("OPTIONS cr,lf,E,R,T,X,B,L,M,G, and V? for verbose"&CRLF);
["l"] ["L"] IF ¬LOGGING THEN
α
OPEN_LOGGING_FILE;
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
OUTSTR("ogging in file name " & LOGFILE & crlf );
β
ELSE OUTSTR("ogging already");
ELSE OUTSTR(" Unrecognized character; type ""?"" for allowable characters."&crlf)
β;
β;
IF I>0 THEN NUM_OF_ERRORS←NUM_OF_ERRORS+1;
GLOBAL_BACKUP←FALSE;
RETURN(C1);
β;
RPTR(ANY_CLASS) PROCEDURE ERROR_basic_REJECT(INTEGER I;STRING S);
α RPTR (ANY_CLASS)R1; R1←ERROR_basic(I,S); REJECT←TRUE; RETURN(R1); β;
PROCEDURE PRINT(STRING S);
α
ifc debug_compile or true thenc comment used to be only debug_compile ;
INTEGER I,J,K,L;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
J←LENGTH(S);
WHILE J>80 DO
α;
K←80;
WHILE K≤J AND ¬EQU(S[K TO K]," ") DO K←K+1;
IF OUTSTRING ≠ NULL THEN outstring←outstring&crlf&s[1 to K]
ELSE outstring←s[1 to K];
! OUT(CHANOUT,S[1 TO K] & crlf);
S←S[K+1 TO J];
J←J-K;
β;
IF OUTSTRING≠NULL THEN outstring←outstring&crlf&s
ELSE outstring←s;
! OUT(CHANOUT,S & crlf);
elsec
INTEGER I;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
IF OUTSTRING≠NULL THEN outstring←outstring&crlf&s
ELSE outstring←s;
! OUT(CHANOUT,S & crlf);
endc;
β;
procedure file_indent(integer i);
α
typed_page_num ← false;
outstr(" "[1 for 2*i]);
β;
PROCEDURE PRINTOUT;
α
IF OUTSTRING≠NULL THEN OUT(CHANOUT,OUTSTRING&CRLF);
IF REJECT=TRUE
THEN α PARSED_STRING←PARSED_STRING[1 TO LENGTH(PARSED_STRING) - LENGTH(TOKEN)];
CURLINE←token2&curliner; β ELSE
CURLINE←CURLINER;
OUTSTRING←NULL;
ifc dup_file thenc
IF WANT_DUP_FILE AND CHANIN > -1 AND CHANNEW > -1 THEN
OUT(CHANNEW,PARSED_STRING);
endc
PARSED_STRING←NULL;
β;
RPTR(ANY_CLASS) PROCEDURE ERROR(INTEGER I;STRING S);
RETURN(ERROR_BASIC(I,S));
RPTR(ANY_CLASS) PROCEDURE ERROR_REJECT(INTEGER I;STRING S);
RETURN(ERROR_BASIC_REJECT(I,S));
PROCEDURE UNDEFINED_VAR(STRING VAR(NULL));
ERROR(0,"UNDEFINED VARIABLE "&VAR);
PROCEDURE UNAFFIXED_VAR(STRING VAR(NULL));
ERROR(0,"UNAFFIXED VARIABLE "&VAR);
! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy;
procedure process_switches(RPTR(file) F);
α RPTR(file_switch) swt;
swt ← file:switches[F];
while swt≠null_record do
α integer i;
for i ← 0 step 1 until switch_max do
if equ(file_switch:name[swt], switch_name[i])
then α switch_setting[i] ← true; done β;
if i > switch_max then
begin
outstr("""" & file_switch:name[swt] & """ unknown switch but will pass it through"& crlf);
switch_name[switch_max+1]←switch_name[switch_max+1]&file_switch:name[swt];
end;
swt ← file_switch:next[swt]
β
β;
boolean procedure got_input(RPTR(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
if file:in_bfrs[F]≤0 then file:in_bfrs[F]←12;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
if eof ∧ length(file:ext[F])=0 ∧ length(file:def_ext[f])≠0 then
α "try default"
file:ext[F] ← file:def_ext[F];
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
β "try default";
process_switches(F);
return(¬eof)
β;
boolean procedure got_output(RPTR(file) F; STRING EXT(NULL));
α
string filename;
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
if length(file:ext[F])=0 then file:ext[F] ← file:def_ext[F];
IF ¬EQU(EXT,NULL) THEN FILE:EXT[F]←EXT;
filename ← make_file_name(F);
enter(file:chn[F], filename, file:eof[F]); process_switches(F);
return(¬eof)
β;
procedure open_logging_file;
if ¬log_file_open then
α;
LOG_file←new_record(file);
copy_file_record(LOG_file,BIN_file);
file:mode[LOG_file]←0; file:in_bfrs[LOG_file]← 0;
file:out_bfrs[LOG_file]←12; file:ext[LOG_file] ← "LOG";
file:device[LOG_file]← "DSK";
file:name[LOG_file]←file:name[AL_file];
if ¬got_output(LOG_file) then
usererr(0, 1, "can't get output");
CHANLOG ← file:chn[LOG_file];
LOGFILE←make_file_name(LOG_file);
log_file_open←true;
logging←true;
β;
ifc dup_file thenc
procedure open_NEW_AL_file(RPTR(FILE)B; STRING EXT);
α
NEW_file←new_record(file);
copy_file_record(NEW_file,B);
file:mode[NEW_file]←0; file:in_bfrs[NEW_file]← 0;
file:out_bfrs[NEW_file]←12; file:ext[NEW_file] ← EXT;
file:device[NEW_file]← "DSK";
file:name[NEW_file]←file:name[PRESENT_file];
CHANNEW ← (file:chn[NEW_file] ← getchan);
if ¬got_output(NEW_file,EXT) then
usererr(0, 1, "can't get output");
NEWFILE←make_file_name(NEW_file);
β;
endc
RPTR (file) procedure open_new_file(reference string s);
begin string word;
integer ignore_blanks_break,file_name_break,ppn_break,break;
RPTR(file)F;
integer procedure ignore_blanks(reference string s);
begin integer break; scan(s, ignore_blanks_break, break); return(break) end;
string procedure filwrd;
begin ignore_blanks(s); return(scan(s, file_name_break, break)) end;
setbreak(
ignore_blanks_break ← getbreak, space & tab, cr, "XRK");
setbreak(
file_name_break ← getbreak, "[:.," & lf, cr, "ISK");
setbreak(
ppn_break ← getbreak, "]" & lf, cr, "ISK");
F←new_record(file);
word ← filwrd; file:chn[F] ← -1; ! file has not been opened flag;
if break=":" then begin file:device[F] ← word; word ← filwrd end;
file:name[F] ← word;
if break="." then file:ext[F] ← filwrd;
if break="[" then
begin
ignore_blanks(s); file:ppn[F] ← "[" & scan(s, ppn_break, break) & "]";
if break="]" then begin ignore_blanks(s); break ← lop(s) end;
end;
if length(file:device[F])=0 then file:device[F] ← "DSK";
return(F);
end;
PROCEDURE CHECK_WANT_COPY;
α String save; save←"Y";
IF EQU(FILE:NAME[PRESENT_FILE],NULL)
THEN IF now_top_file then FILE:NAME[PRESENT_FILE]←"ALMAIN" else save←"N";
! OUTSTR(CRLF&"Teletype input requested. Want to save on disk?(Y or N)");
! ALTERNATIVE METHOD SAVE←INCHRW;
IF SAVE = "Y"
THEN
α RPTR(FILE)F;
F←NEW_RECORD(FILE);
copy_file_RECORD(F,PRESENT_FILE);
file:mode[F]←0;file:in_bfrs[F]←0;
file:out_bfrs[F]←12; if file:ext[F]=null then file:ext[f]←"TTY";
file:chn[f]←-1;
FILE:DEVICE[F]←"DSK";
IF ¬GOT_OUTPUT(F) THEN USERERR(0,1,"Can't get output");
CHANTTYO←FILE:CHN[F];
β
ELSE CHANTTYO←-1;
β;
BOOLEAN PROCEDURE ASK_WANT_DUP_FILE;
α STRING S;
OUTSTR(CRLF&"WANT TO SAVE DUPLICATE FILE (Y OR N) ? ");
S←INCHRW; IF S="Y" OR S="y" then RETURN(TRUE) else return(false);
β;
! push_source_list,pop_source_list,new_expr_rec;
RPTR(SOURCE_LIST) PROCEDURE PUSH_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
RPTR(SOURCE_LIST) S;
S←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:NEXT[S]←S1;
SOURCE_LIST:CUR_STRING[S]←CURLINE;
SOURCE_LIST:CUR_STRINGR[S]←TOKEN_FRONT&CURLINER;
SOURCE_LIST:PN[S]←PAGENUM;
SOURCE_LIST:LN[S]←LINENUM;
SOURCE_LIST:CHAN[S]←CHANIN;
SOURCE_LIST:FILE_NAME[S]←INFILE;
SOURCE_LIST:FILE_PTR[S]←PRESENT_FILE;
SOURCE_LIST:CHANTTYO[S]←CHANTTYO;
SOURCE_LIST:CHANNEW[S]←CHANNEW;
! SOURCE_LIST:P_STRING[S]←PARSED_STRING;
! PARSED_STRING←NULL;
PRINTOUT;
CHANTTYO←-1;
CURLINE←CURLINER←NULL;
RETURN(S);
β;
RPTR(SOURCE_LIST) PROCEDURE POP_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
CURLINE←SOURCE_LIST:CUR_STRING[S1];
CURLINER←SOURCE_LIST:CUR_STRINGR[S1];
PAGENUM←SOURCE_LIST:PN[S1];
LINENUM←SOURCE_LIST:LN[S1];
CHANIN←SOURCE_LIST:CHAN[S1];
PRESENT_FILE←SOURCE_LIST:FILE_PTR[S1];
INFILE←SOURCE_LIST:FILE_NAME[S1];
CHANTTYO←SOURCE_LIST:CHANTTYO[S1];
CHANNEW←SOURCE_LIST:CHANNEW[S1];
! PARSED_STRING←SOURCE_LIST:P_STRING[S1];
RETURN(SOURCE_LIST:NEXT[S1]);
β;
! id info processing routines;
! FLAGS
BIT 35 USE
34 DEFINE
33 AFFIX
0-9 PAGENUM
10-19 LINENUM ;
DEFINE RID1=[RPTR(ID_LIST)R1];
DEFINE ARID1=[RPTR(ID_LIST,ARRAY_LIST)R1; INTEGER TTOKEN(ID_TOKEN)];
PROCEDURE USE(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '1;
BOOLEAN PROCEDURE USED(RID1);
RETURN(ID_LIST:FLAGS[R1] LAND '1);
PROCEDURE UNFIX(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LAND '777777777773;
PROCEDURE PUT_ID_PAGE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_ID_LINE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE ID_PAGE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 10)LAND '1777);
INTEGER PROCEDURE ID_LINE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 20)LAND '1777);
DEFINE AID1= [RPTR(ARRAY_LIST) A1];
BOOLEAN PROCEDURE array_USED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '1);
BOOLEAN PROCEDURE ARRAY_DEFINED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '2);
BOOLEAN PROCEDURE ARRAY_AFFIXED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '4);
PROCEDURE ARRAY_USE(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '1;
PROCEDURE ARRAY_DEFIN(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '2;
PROCEDURE ARRAY_AFFIX(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '4;
PROCEDURE ARRAY_UNFIX(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LAND '777777777773;
PROCEDURE PUT_ARRAY_PAGE(AID1);
ARRAY_LIST:FLAGS[A1]←(((ARRAY_LIST:FLAGS[A1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_ARRAY_LINE(AID1);
ARRAY_LIST:FLAGS[A1]←(((ARRAY_LIST:FLAGS[A1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE ARRAY_PAGE(AID1);
RETURN((ARRAY_LIST:FLAGS[A1] ROT 10)LAND '1777);
INTEGER PROCEDURE ARRAY_LINE(AID1);
RETURN((ARRAY_LIST:FLAGS[A1] ROT 20)LAND '1777);
DEFINE PID1= [RPTR(PROCEDURE_LIST) P1];
BOOLEAN PROCEDURE PROCEDURE_USED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '1);
BOOLEAN PROCEDURE PROCEDURE_DEFINED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '2);
BOOLEAN PROCEDURE PROCEDURE_AFFIXED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '4);
PROCEDURE PROCEDURE_USE(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '1;
PROCEDURE PROCEDURE_DEFIN(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '2;
PROCEDURE PROCEDURE_AFFIX(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '4;
PROCEDURE PROCEDURE_UNFIX(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LAND '777777777773;
PROCEDURE PUT_PROCEDURE_PAGE(PID1);
PROCEDURE_LIST:FLAGS[P1]←(((PROCEDURE_LIST:FLAGS[P1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_PROCEDURE_LINE(PID1);
PROCEDURE_LIST:FLAGS[P1]←(((PROCEDURE_LIST:FLAGS[P1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE PROCEDURE_PAGE(PID1);
RETURN((PROCEDURE_LIST:FLAGS[P1] ROT 10)LAND '1777);
INTEGER PROCEDURE PROCEDURE_LINE(PID1);
RETURN((PROCEDURE_LIST:FLAGS[P1] ROT 20)LAND '1777);
BOOLEAN PROCEDURE DEFINED(ARID1);
IF TTOKEN=ID_TOKEN THEN
RETURN(ID_LIST:FLAGS[R1] LAND '2)
ELSE RETURN(ARRAY_DEFINED(R1));
BOOLEAN PROCEDURE AFFIXED(ARID1);
IF TTOKEN=ID_TOKEN THEN
RETURN(ID_LIST:FLAGS[R1] LAND '4)
ELSE RETURN(ARRAY_AFFIXED(R1));
PROCEDURE DEFIN(ARID1);
IF TTOKEN=ID_TOKEN THEN
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '2
ELSE ARRAY_DEFIN(R1);
PROCEDURE AFFIX(ARID1);
IF TTOKEN=ID_TOKEN THEN
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '4
ELSE ARRAY_AFFIX(R1);
! read;
INTEGER BRCHAR2;
STRING PROCEDURE KNVRT(STRING OLD_STR);
RETURN( SCAN(OLD_STR, KNVRT_BREAK, BRCHAR2));
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT,TEXT2;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN > -1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT;
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN>-1 THEN α STRING CURR;
CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
IF CHANTTYO≥0 THEN OUT(CHANTTYO, CURLINE);
macro_stack_top←macro_st2; macro_st2←null_record;β;
IF CHANIN≤-1 THEN
α "pop macro"
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
macro_stack_top←macro_st2←SOURCE_LIST:macro_stack_TOP[TOP_SOURCE];
CURRENT_MACRO←SOURCE_LIST:CUR_MACRO[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
IF (BTABLE=WORD_r_BREAK) OR (BTABLE=word_s_break) OR (BTABLE=non_digit_break)
then α brchar←space; return(text); β;
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
printout;
RELEASE(CHANIN);
if channew ≥ 0 AND (NUM_OF_ERRORS_MODIFIED >0)
then α BOOLEAN FLAG;
IF ¬ASK_WANT_DUP_FILE THEN RENAME(CHANNEW,NULL,0,FLAG);
RELEASE(CHANNEW);
β;
IF EQU(FILE:DEVICE[PRESENT_FILE],"TTY")
THEN if chanttyo ≥ 0 then RELEASE(CHANTTYO);
CURRENT_MACRO←NULL_RECORD;
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←POP_SOURCE_LIST(TOP_SOURCE);
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN
IF BLOCK_LEVEL > 0
THEN ERROR(500,"End of file encountered unexpectedly"&crlf&
"Probably BEGIN-ENDs have not been matched.")
ELSE RETURN(NULL);
TEXT2←SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN>-1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT2&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT2;
TEXT←TEXT&TEXT2;
β;
TOKEN2←TEXT;
IFC FULL_SET THENC RETURN(KNVRT(TEXT)); ELSEC RETURN(TEXT); ENDC
β;
! macro handling routine;
BOOLEAN procedure macro_handler;
α "macro_handler"
INTEGER HASH_ENTRY; STRING MACRO_NAME;
INTEGER PARAM_COUNT;
RPTR (MACRO_LIST) MAC_POINT;
RPTR (PARAM_LIST) TOP_PARAM, NEW_PARAM, LAST_PARAM;
BOOLEAN STATUS;
LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
STATUS←FALSE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GOTO FLUSH;
β;
STATUS←TRUE;
do α "define_macro"
INSIDE_MACRO_DEFINITION←TRUE;
PARAM_COUNT←0; GET_TOKEN;
INSIDE_MACRO_DEFINITION←FALSE;
IF TYPE_OF_TOKEN≠undeclared_token and SPECIAL_INFO=BLOCK_LEVEL
THEN F_STATE(0,56,"Can only define unreserved ID's.");
MACRO_NAME←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"(") THEN
α "macro_parameters"
TOP_PARAM←LAST_PARAM←NEW_RECORD(PARAM_LIST);
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token
THEN F_STATE(0,57,"Can only use unreserved ID's as parameter names.");
PARAM_COUNT←PARAM_COUNT+1; NEW_PARAM←NEW_RECORD(PARAM_LIST);
PARAM_LIST:NEXT[LAST_PARAM]←NEW_PARAM;
PARAM_LIST:USER_ID[NEW_PARAM]←TOKEN; LAST_PARAM←NEW_PARAM;
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
α
ERROR(58,"Need either comma or right paren here.");
REJECT←TRUE; TOKEN←")";
β;
β;
TOP_PARAM←PARAM_LIST:NEXT[TOP_PARAM];
GET_TOKEN;
β "macro_parameters";
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(59,"Need = here.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠MACRO_BODY_TOKEN THEN F_STATE(0,60,"MACRO BODY DEFINITION REQUIRES DEFINITION BETWEEN ⊂ AND ⊃")
ELSE
α
! bind macros;
if param_count>0 then
α "PARAMS"
string array param_id, param_arg[1:param_count];
integer i,width,digits;
string t1;
string t, processed_token;
STRING BREAK_STRING;
string t2;
RPTR(param_list) param_ptr;
param_ptr←top_param;
BREAK_STRING←NULL;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(-2,0);
if chanin>0 then t1←"00" else t1←cvs(abs(chanin));
for i ← 1 step 1 until param_count do
α
param_id[i]←param_list:user_id[param_ptr];
param_arg[i]←(param_list:id[param_ptr]← "∀_"&MACRO_NAME&t1 & "__"&cvs(i));
param_ptr←param_list:next[param_ptr];
β;
SETFORMAT(WIDTH,DIGITS);
processed_token← NULL;
do α
integer brchar,brchar2;
t2←scan(token,non_blank_break,brchar);
if t2≠null then processed_token←processed_token&t2;
t←scan(token,word_s_break,brchar2);
if t≠null then
α for i←1 step 1 until param_count do
if equ(t,param_id[i]) then t←param_arg[i];
processed_token←processed_token&t;
β;
if brchar2≠null then processed_token←processed_token&brchar2;
β until length(token)=0;
token←processed_token;
β "PARAMS";
! done binding macros;
β;
if chanin≤-1
then mac_point←insert_entry(macro_name,macro_in_macro_type_table)
else mac_point←insert_entry(macro_name,macro_type_table);
MACRO_LIST:VALUE[MAC_POINT]←TOKEN;
MACRO_LIST:NUM[MAC_POINT]←PARAM_COUNT;
MACRO_LIST:PARAMS[MAC_POINT]←TOP_PARAM;
MACRO_LIST:BLOCK_LEVEL_OF_DEFN[MAC_POINT]←BLOCK_LEVEL;
get_token;
β "define_macro"
until ¬equ(token, ",");
if equ(token, ";") then reject ← true;
FLUSH: RETURN(STATUS);
β "macro_handler";
! expand_macro;
PROCEDURE EXPAND_MACRO(RPTR(MACRO_LIST)CMACRO);
α RPTR(macro_list) m1;
STRING PROCESSED_BODY;
RPTR(SOURCE_LIST)NEW_SOURCE2;
PROCESSED_BODY←NULL;
NEW_SOURCE2←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CUR_MACRO[NEW_SOURCE2]←CURRENT_MACRO;
CURRENT_MACRO←CUR_MACRO;
α "expand macro"
STRING MAC_ID; RPTR(PARAM_LIST) PARAMS;
STRING BODY;
INTEGER BRCHAR2;
M1←CMACRO;
PARAMS←MACRO_LIST:PARAMS[M1];
MAC_ID←MACRO_LIST:ID[M1];
read(non_blank_break); token←read(word_R_break);
if token=null then token←read(word_s_break);
IF ¬EQU(BRCHAR,"(") AND PARAMS≠NULL
THEN ERROR(59,"Parametered macro used without params.")
ELSE IF ¬EQU(BRCHAR,"(")
THEN
α
IF TOKEN= NULL
THEN α CURLINER←BRCHAR&CURLINER;
PARSED_STRING←PARSED_STRING[1 TO ∞ - 1];
β
ELSE α CURLINER←TOKEN2&CURLINER;
parsed_string←parsed_string[1 to length(parsed_string) - length(token)]; β;
BODY←MACRO_LIST:VALUE[M1];
β
ELSE
α "macro parameters"
STRING T,t2r,t3;
FOR I←1 STEP 1 UNTIL MACRO_LIST:NUM[M1] DO
α RPTR(MACRO_LIST)SUB_MACRO;
IF EQU(TOKEN,")") THEN
ERROR(60,"Number of parameters disagree with definition.");
GET_TOKEN(true);
SUB_MACRO←INSERT_ENTRY(PARAM_LIST:ID[PARAMS],MACRO_IN_MACRO_TYPE_TABLE);
MACRO_LIST:VALUE[SUB_MACRO]←TOKEN;
IF EQU(TOKEN,"-") THEN
BEGIN
GET_TOKEN;
IF TYPE_OF_TOKEN=NUMERIC_TOKEN THEN
MACRO_LIST:VALUE[SUB_MACRO]←"-"&TOKEN
ELSE REJECT←TRUE;
END;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(62,"NEED EITHER COMMA OR RIGHT PAREN HERE;
if you use more than one token as argument to a macro call, enclose it between the
macro delimiters ⊂⊃");
PARAMS←PARAM_LIST:NEXT[PARAMS];
β;
IF ¬EQU(TOKEN,")") THEN ERROR(62,"Number of parameters don't match the defn.");
body←macro_list:value[m1];
β "macro parameters";
PROCESSED_BODY←processed_body&body;
β "expand macro";
SOURCE_LIST:NUM[NEW_SOURCE2]←MACRO_LIST:NUM[M1];
SOURCE_LIST:NEXT[NEW_SOURCE2]←TOP_SOURCE;
SOURCE_LIST:CUR_STRING[NEW_SOURCE2]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE2]←CURLINER;
SOURCE_LIST:PN[NEW_SOURCE2]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE2]←LINENUM;
SOURCE_LIST:MACRO_STACK_TOP[NEW_SOURCE2]←MACRO_STACK_TOP;
SOURCE_LIST:MACRO_STRING[NEW_SOURCE2]←MACRO_STRING;
SOURCE_LIST:FILE_PTR[NEW_SOURCE2]←PRESENT_FILE;
SOURCE_LIST:CHAN[NEW_SOURCE2]←CHANIN;
IF CHANIN≥0 THEN CHANIN←-1 ELSE CHANIN←CHANIN-1;
MACRO_STRING←processed_body;
CURLINE←CURLINER←processed_body;
TOP_SOURCE←NEW_SOURCE2;
GET_TOKEN;
WHILE EQU(TOKEN,"DEFINE") DO
α
macro_handler; get_token; GET_TOKEN;
β;
β;
! get_token;
! THIS PROCEDURE GETS THE NEXT TOKEN.
STRING TOKEN ← TOKEN FOUND
INTEGER TYPE_OF_TOKEN← SPECIAL_TOKEN, NUMERIC_TOKEN, STRING_TOKEN, ID_TOKEN,
MACRO_TOKEN, METRIC_TOKEN, UNDEFINED_TOKEN, RESERVED_TOKEN
ARRAY_TOKEN, PROCEDURE_TOKEN
INTEGER TYPE_OF_RES_WORD ← -VE IF NOT RESERVED WORD
INTEGER ID_TYPE ← VALID FOR TYPE_OF_TOKEN=ID_TOKEN
INTEGER ARRAY_TYPE ← VALID FOR TYPE_OF_TOKEN=ARRAY_TOKEN
INTEGER PROCEDURE_TYPE ← VALID FOR TYPE_OF_TOKEN=PROCEDURE_TOKEN
INTEGER SPECIAL_INFO ← PERTAINS TO INFO ABOUT RES_WORD
INTEGER BLOCK_LEVEL_OF_DEFN ← PERTAINS TO BLOCK LEVEL OF DEFN
INTEGER RESERVED_TOKEN_PTR← POINTER TO POSITION IN RESERVED,COM[0:RESERVED_HASHER]
REAL REALNUM← REAL NUMBER FOUND
RPTR TOKEN_PTR← GENERAL POINTER TO TOKEN FOUND AS ID, ETC;
RECURSIVE PROCEDURE GET_TOKEN(boolean noexpand(false));
α "get_token" BOOLEAN T; INTEGER POINT;
RECORD_POINTER(MACRO_LIST) PROCEDURE LOOK_FOR_MACRO;
α RECORD_POINTER (MACRO_LIST) R1;
IF MACRO_STACK_TOP≠NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_IN_MACRO_TYPE_TABLE);
IF R1=NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_TYPE_TABLE);
RETURN(R1);
β;
! IF REJECT THEN α REJECT←FALSE; ! ************ ; ! RETURN; ! ************; ! β;
IF REJECT
THEN α CURLINER←TOKEN2&CURLINER;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING[1 TO LENGTH(PARSED_STRING) - LENGTH(TOKEN2)];
REJECT←FALSE; β;
BLOCK_LEVEL_OF_DEFN←RESERVED_TOKEN_PTR←
ID_TYPE←TYPE_OF_RES_WORD←SPECIAL_INFO←-100;
TOKEN_PTR←NULL_RECORD;
TYPE_OF_TOKEN←special_token; T←TRUE;
WHILE T DO
α "while_T"
TOKEN_FRONT←READ(non_blank_break); TOKEN←READ(word_R_break);
IF EQU(TOKEN,NULL)
THEN
α "isolated break"
CASE BRCHAR OF
α
["."]
α REAL NUM; STRING S1; S1←CURLINER[2 FOR ∞];
IF "0"≤S1≤"9"
THEN α NUM←REALSCAN(CURLINER,BRCHAR);
TYPE_OF_TOKEN←numeric_token; REALNUM←NUM; TOKEN←CVG(NUM) β
ELSE α TOKEN2←TOKEN←"."; CURLINER←CURLINER[2 TO ∞]; β;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&"."&S1[1 FOR LENGTH(S1) - LENGTH(CURLINER)];
β;
ELSE ;
[SQUOTE]
α REAL NUM; STRING S1;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&LOP(CURLINER);
IF "0"≤CURLINER[1 FOR 1]≤"7"
THEN α S1←CURLINER; TYPE_OF_TOKEN←numeric_token; REALNUM←NUM;
TOKEN←CVS(NUM); REALNUM←CVO(TOKEN);
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&CURLINER[1 FOR LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE TOKEN2←TOKEN←squote;
β
β;
IF EQU(TOKEN,NULL) THEN α READ(word_S_break); TOKEN2←TOKEN←BRCHAR;
β;
β "isolated break";
IF EQU(TOKEN,OPEN_BRACE) THEN TOKEN←READ(close_brace_break) ELSE T←FALSE;
β "while_T";
if token=delimiter_1
then
α "found_macro_body" integer lvl;
token←read(macro_delimiter_break); type_of_token ← macro_body_token;
if brchar=delimiter_2 then return; ! ******** ;
lvl ← 2; if brchar≠delimiter_1 then error(200, "macro body scan lost");
do
α token ← token & brchar & read(macro_delimiter_break);
if brchar=delimiter_2
then lvl ← lvl-1
else if brchar=delimiter_1
then lvl ← lvl+1
else error(200, "macro body scan lost");
β
until lvl ≤ 0;
return; ! ************* ;
β "found_macro_body";
IF TOKEN=dquote
THEN
α "found_string"
STRING S1;
TOKEN←READ(quote_break); TYPE_OF_TOKEN←string_token;
while curliner=dquote do α IF CHANIN > -1 THEN PARSED_STRING←PARSED_STRING&(S1←lop(curliner));
token ← token & S1 & read(quote_break); β;
! ********* ; RETURN; ! ********** ;
β "found_string";
! look for reserved word;
IF TYPE_OF_TOKEN=special_token
THEN
α POINT←HASH(TOKEN,reserved_hasher);
WHILE ¬EQU(RESERVED[POINT],NULL) AND ¬EQU(RESERVED[POINT],TOKEN) DO
POINT←(POINT+1)MOD reserved_hasher;
IF RESERVED[POINT]=TOKEN
THEN
α "reserved word" INTEGER VAL; TYPE_OF_TOKEN←reserved_token; VAL←COM_TYPE[POINT];
RESERVED_TOKEN_PTR←POINT;
IF VAL≥reserved_hasher
THEN α SPECIAL_INFO←(VAL DIV reserved_hasher); TYPE_OF_RES_WORD←(VAL MOD reserved_hasher); β
ELSE α SPECIAL_INFO←0; TYPE_OF_RES_WORD←VAL; β;
β "reserved word";
α "not reserved"
RECORD_POINTER(ANY_CLASS)POINT,POINT2;
IF ¬("0" ≤ token ≤ "9")
THEN
α "MAC_TEST"
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←ID_TOKEN; BLOCK_LEVEL_OF_DEFN←ID_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β
ELSE
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,ARRAY_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←ARRAY_TOKEN; BLOCK_LEVEL_OF_DEFN←ARRAY_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β
ELSE
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,PROCEDURE_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←PROCEDURE_TOKEN; BLOCK_LEVEL_OF_DEFN←PROCEDURE_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
IF (POINT2←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE))≠NULL_RECORD
THEN
α IF TOKEN_PTR=NULL_RECORD
THEN α TOKEN_PTR←POINT2; TYPE_OF_TOKEN←METRIC_TOKEN;β
ELSE IF DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[POINT2] > BLOCK_LEVEL_OF_DEFN
THEN α TYPE_OF_TOKEN←METRIC_TOKEN; TOKEN_PTR←POINT2;
BLOCK_LEVEL_OF_DEFN←DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
β;
IF (CUR_MACRO←LOOK_FOR_MACRO)≠NULL_RECORD and ¬noexpand
THEN IF TOKEN_PTR=NULL_RECORD OR MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO]>
BLOCK_LEVEL_OF_DEFN
THEN
α "MACRO"
BLOCK_LEVEL_OF_DEFN←MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO];
EXPAND_MACRO(CUR_MACRO);
β "MACROλ{
β "MAC_TEST"
ELSE
α "numeric" REAL NUM1,NUM2; INTEGER NUMGARB;
TYPE_OF_TOKEN←numeric_token; NUM1←INTSCAN(TOKEN,NUMGARB);
IF ¬EQU(TOKEN,NULL) THEN ERROR(0,"Illegal token." & crlf & "Garbage after digits will be ignored.");
IF BRCHAR="."
THEN
α STRING S1; S1←CURLINER;
CURLINER←"0"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN2←TOKEN←CVG(NUM1+NUM2);
REALNUM←NUM1+NUM2;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&S1[1 TO LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE IF BRCHAR="@"
THEN
α STRING S1; S1←CURLINER;
CURLINER←"1"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1*NUM2);
REALNUM←NUM1*NUM2;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&S1[1 TO LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE α TOKEN←CVG(NUM1); REALNUM←NUM1; β;
β "numeric";
β "not reserved";
β;
if type_of_token=id_token
then α if ¬inside_declare_p then use(token_ptr);
if id_list:type[token_ptr]=string_value
then if inside_string_declaration
then id_type←string_value
else α type_of_token←string_token; token←id_list:body[token_ptr]; token_ptr←null_record; β
else id_type←id_list:type[token_ptr];
β
else if type_of_token=array_token
then α if ¬inside_declare_p then array_use(token_ptr);
array_type←array_list:type[token_ptr];
β
else if type_of_token=procedure_token
then α if ¬inside_declare_p then procedure_use(token_ptr);
procedure_type←procedure_list:type[token_ptr];
β
else if type_of_token=special_token then type_of_token←undeclared_token;
β "get_token";
boolean procedure check_next_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α string array s[1:10]; integer i1,j1;label l1,l2; string st;
s[1]←s1;s[2]←s2;s[3]←s3;s[4]←s4;s[5]←s5;s[6]←s6;s[7]←s7;s[8]←s8;s[9]←s9;s[10]←s10;
i1←0;st←null;
while s[i1+1]≠null do α i1←i1+1;st←st & s[i1] & ","; β;
if i1 > 1 then
α
l1: get_token;
for j1←1 step 1 until i1
do if equ(token , s[j1]) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need one of "&st& " here, patchable error ");
if patch_code=true
then α patch_code←false; return(false); β
else goto l1;
β else
α
l2: get_token;
if equ(token,s1) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need "&s1&" here, continue will insert it.");
if patch_code = true
then α patch_code←false; return(false); β
else goto l2;
β;
β;
boolean procedure check_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α
reject←true;
return(check_next_token(err_code,err_mess,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10));
β;
boolean procedure check_next_token_type(integer err_code; string err_mess;
integer ttype);
α Label l1;
get_token;
l1: if type_of_token=ttype then return(true);
patch_code←true;
error(err_code,err_mess);
if patch_code=true then α patch_code←false; return(false); β
else goto l1;
β;
boolean procedure check_token_type(integer err_code; string err_mess;
integer ttype);
α
reject←true;
return(check_next_token_type(err_code,err_mess,ttype));
β;
boolean procedure token_equ(string s1,s2(null),s3(null),s4(null),s5(null),
s6(null),s7(null),s8(null),s9(null),s10(null));
α string s;
for s←s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
do if equ(null,s) then return(false)
else if equ(token,s) then return(true);
return(false);
β;
! check, inverse, multiply and divide dimensions; ! CHECK_EXP_TYPE_DIMENS;
RPTR(DIMENS_EXPONENT)
PROCEDURE CHECK_DIMENSIONS_PROG(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR(DIMENS_EXPONENT)II1,II2,II3;STRING SS;BOOLEAN SAME;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α REJECT←FALSE; GET_TOKEN; β;
return(r1);
β;
BOOLEAN PROCEDURE ISNIL_DIMENS(RPTR(DIMENS_EXPONENT) DD);
α BOOLEAN B; B←TRUE; IF DD=NULL_RECORD OR DD=NIL_DIMENS THEN RETURN(TRUE);
redefine xx(temp)= [ B ← B ∧ (DIMENS_EXPONENT:temp[DD] = 0) ; ];
BASIC_DIMENSIONS;
RETURN(B);
β;
SS←NULL;
SAME←TRUE;
II1←D1; II2←D2;
IF II1≠II2 THEN
α IF II1=NULL_RECORD THEN II1←NIL_DIMENS;
IF II2=NULL_RECORD THEN II2←NIL_DIMENS;
redefine xx(temp)= [ IF DIMENS_EXPONENT:temp[II1]≠DIMENS_EXPONENT:temp
[II2] THEN α IF LENGTH(SS)≠0 THEN SS←SS&", temp " ELSE SS←" temp ";
SAME←FALSE;β;];
IF ¬STRICT_DIMEN_CHECK OR (¬ISNIL_DIMENS(II2) AND ¬ISNIL_DIMENS(II1))
THEN α BASIC_DIMENSIONS;
IF SAME THEN II3←II1
ELSE ERROR(122, SS & "Dimensions don't match on "&S&".");
β
ELSE IF ¬ISNIL_DIMENS(II1) THEN II3←II1 ELSE II3←II2;
β
ELSE IF ISNIL_DIMENS(II1) THEN II3←NIL_DIMENS ELSE II3←II1;
IF SAME THEN RETURN(II3);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE INVERSE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←-DIMENS_EXPONENT:temp[D2];];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE SQRT_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[D2]/2;];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE MULTIPLY_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←D3;
β
ELSE
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[d2]+
DIMENS_EXPONENT:temp[D3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE DIVIDE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←INVERSE_DIMENSIONS(D3);
β
ELSE
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[D2]-
DIMENS_EXPONENT:temp[D3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS_PROG(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α
CHECK_DIMENSIONS_PROG(ERROR_MESS,PTR,EXP_DIMENS);
IF EXP_TYPE=DESIRED_EXP_TYPE THEN RETURN (TRUE) ELSE RETURN (FALSE);
β;
! check_entry,insert_entry into tables;
RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
α
RPTR(ANY_CLASS)R1;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α R1←SYMBOL_TABLE[HASH(S,ID_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,ID_LIST:NAME[R1]) DO R1←ID_LIST:NEXT[R1];
β;
[array_TYPE_TABLE] α R1←array_SYMBOL_TABLE[HASH(S,array_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,array_LIST:NAME[R1]) DO R1←array_LIST:NEXT[R1];
β;
[procedure_TYPE_TABLE] α R1←procedure_SYMBOL_TABLE[HASH(S,procedure_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,procedure_LIST:NAME[R1]) DO R1←procedure_LIST:NEXT[R1];
β;
[MACRO_TYPE_TABLE] α R1←MACRO_TABLE[HASH(S,MACRO_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[R1]) DO R1←MACRO_LIST:NEXT[R1];
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α R1←MACRO_STACK_TOP;
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[MACRO_STACK:LIST_PTR[R1]])
DO R1←MACRO_STACK:STACK_LINK[R1];
IF R1≠NULL_RECORD THEN R1←MACRO_STACK:LIST_PTR[R1];
β;
[DIMENSION_TYPE_TABLE]
α R1←DIMENS_TABLE[HASH(S,METRIC_HASHER)];
WHILE R1≠NULL AND ¬ EQU(S,DIMENS_EXPONENT:NAME[R1]) DO R1←DIMENS_EXPONENT:NEXT[R1];
β
β;
RETURN(R1);
β;
RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S; INTEGER TABLE_TYPE;
RPTR(ANY_CLASS) RR1(NULL_RECORD));
α
RPTR(ANY_CLASS) R1; INTEGER INDEX;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(ID_LIST) ELSE R1←RR1;
ID_LIST:NEXT[R1]←SYMBOL_TABLE[INDEX←HASH(S,ID_HASHER)];
ID_LIST:NAME[R1]←S;
SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α ID_LIST:LAST[R1]←TOP_ID;
ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_ID_PAGE(R1); PUT_ID_LINE(R1);
TOP_ID←R1;DEC_NUM←DEC_NUM+1; β;
β;
[array_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(array_LIST) ELSE R1←RR1;
array_LIST:NEXT[R1]←array_SYMBOL_TABLE[INDEX←HASH(S,array_HASHER)];
array_LIST:NAME[R1]←S;
array_SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α array_LIST:LAST[R1]←TOP_array;
array_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_array_PAGE(R1); PUT_array_LINE(R1);
top_array←R1;array_DEC_NUM←array_DEC_NUM+1; β;
β;
[procedure_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(procedure_LIST) ELSE R1←RR1;
procedure_LIST:NEXT[R1]←procedure_SYMBOL_TABLE[INDEX←HASH(S,procedure_HASHER)];
procedure_LIST:NAME[R1]←S;
procedure_SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α procedure_LIST:LAST[R1]←TOP_procedure;
procedure_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_procedure_PAGE(R1); PUT_procedure_LINE(R1);
top_procedure←R1;procedure_DEC_NUM←procedure_DEC_NUM+1; β;
β;
[MACRO_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(MACRO_LIST) ELSE R1←RR1;
MACRO_LIST:NEXT[R1]←MACRO_TABLE[INDEX←HASH(S,MACRO_HASHER)];
MACRO_LIST:ID[R1]←S;
MACRO_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α MACRO_LIST:LAST[R1]←TOP_MACRO;
TOP_MACRO←R1; MACRO_DEC_NUM←MACRO_DEC_NUM+1; β;
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α
RPTR (macro_list)r2;
IF RR1=NULL_RECORD THEN R2←NEW_RECORD(MACRO_list) ELSE R2←RR1;
r1←new_record(macro_stack);
MACRO_STACK:STACK_LINK[R1]←macro_stack_top;
macro_stack:list_ptr[r1]←r2;
MACRO_STACK_TOP←R1;
macro_list:id[r2]←s;
R1←R2;
β;
[DIMENSION_TYPE_TABLE]
α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(DIMENS_EXPONENT) ELSE R1←RR1;
DIMENS_EXPONENT:NAME[R1]←S;
DIMENS_EXPONENT:NEXT[R1]←DIMENS_TABLE[INDEX←HASH(S,METRIC_HASHER)];
DIMENS_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α DIMENS_EXPONENT:LAST[R1]←TOP_DIMENS;
TOP_DIMENS←R1; DIMEN_DEC_NUM←DIMEN_DEC_NUM+1; β;
β
β;
RETURN(R1);
β;
! expression evaluation routines;
RCLASS EXPR (STRING BODY; INTEGER TYPE; RPTR(DIMENS_exponent)DIMEN; RPTR(EXPR)NEXT);
SIMPLE INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
α INTEGER L,M,U;
L←LB; U←UB;
DO α M←(U+L)/2;
IF A[M]=VAL THEN RETURN(M)
ELSE IF A[M]>VAL THEN U←M-1
ELSE L←M+1;
β UNTIL L>U;
RETURN(0);
β;
define #ntype=10;
SIMPLE INTEGER PROCEDURE FUNC(INTEGER ARRAY T);
α INTEGER I,R; R←0;
FOR I←0 STEP 1 UNTIL 4 DO R←R*#NTYPE + T[I];
RETURN(R);
β;
RPTR (EXPR) PROCEDURE MK_EXPR
(STRING BODY; INTEGER TYPE; RPTR(DIMENS_EXPONENT)DIMEN);
α RPTR(EXPR)X; X←NEW_RECORD(EXPR);
EXPR:BODY[X]←BODY; EXPR:TYPE[X]←TYPE;
EXPR:DIMEN[X]←DIMEN; RETURN(X);
β;
! OP, OP_TYPE,RES_TYPE,ARG1, ARG2, ARG3, DIMENR, DIMEN1, DIMEN2, DIMEN2,RESULT ;
REQUIRE "⊂⊃⊂⊃" DELIMITERS;
DEFINE OPERATIONS = ⊂
XX("¬", NOT_X, #SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D, NOT)
XX("≡", EQV_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, EQV)
XX("∧", AND_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, AND)
XX("∨", OR_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, OR)
XX("⊗", XOR_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, XOR)
XX("=", SEQ_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SEQ)
XX("≠", SNE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SNE)
XX(">", SGT_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SGT)
XX("<", SLT_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SLT)
XX("≥", SGE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SGE)
XX("≤", SLE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SLE)
XX("UNIT",UVECT_X, #VT,100,#VT, 0, 0,NIL_D,ANY_D, NIL_D, NIL_D, UVECT)
XX("AXIS",AXIS_X, #VT,100,#RT, 0, 0,NIL_D,ANGL_D, NIL_D, NIL_D, AXIS)
XX("POS",POS_X, #VT,100,#FR, 0, 0,DIST_D,DIST_D,NIL_D, NIL_D, POS)
XX("POS",POS_X, #VT,100,#TR, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, POS)
XX("ORIENT",ORIENT_X, #RT,100,#FR, 0, 0,ANGL_D,DIST_D,NIL_D, NIL_D, ORIENT)
XX("ORIENT",ORIENT_X, #RT,100,#TR, 0, 0,ANGL_D,ANY_D, NIL_D, NIL_D, ORIENT)
XX("INV",RINV_X, #RT,100,#RT, 0, 0,ANGL_D, ANGL_D,NIL_D, NIL_D, TINVRT)
XX("INV",RINV_X, #TR,100,#TR, 0, 0,SAME2_D,ANY_D,NIL_D, NIL_D, TINVRT)
XX("MODULUS",SABS_X, #SC,100,#SC, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, SABS)
XX("MODULUS",SABS_X, #SC,100,#VT, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, VMAGN)
XX("MODULUS",SABS_X, #SC,100,#RT, 0, 0,ANGL_D,ANGL_D,NIL_D, NIL_D, RMAGN)
XX("+", PLUS_X, #SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SMUL +1.0)
XX("+", PLUS_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, SADD)
XX("+", PLUS_X, #VT,100,#VT, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SVMUL 1.00000)
XX("+", PLUS_X, #VT,120,#VT, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, VADD)
XX("+", PLUS_X, #FR,210,#VT, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVADD)
XX("+", PLUS_X, #TR,210,#VT, #TR, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVADD)
XX("+", PLUS_X, #FRE,120,#FR, #VT, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVADD)
XX("+", PLUS_X, #TR,120,#TR, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVADD)
XX("-", MINUS_X,#SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SNEG)
XX("-", MINUS_X,#SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, SSUB)
XX("-", MINUS_X,#VT,100,#VT, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, VSUB NILVECT )
XX("-", MINUS_X,#VT,120,#VT, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, VSUB)
XX("-", MINUS_X,#FRE,120,#FR, #VT, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVSUB)
XX("-", MINUS_X,#TR,120,#TR, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVSUB)
XX("*", TIMES_X,#SC,120,#SC, #SC, 0, MULT_D, ANY_D, ANY_D, NIL_D, SMUL)
XX("*", TIMES_X,#VT,120,#SC, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, SVMUL)
XX("*", TIMES_X,#VT,210,#VT, #SC, 0, MULT_D, ANY_D, ANY_D, NIL_D, SVMUL)
XX("*", TIMES_X,#VT,120,#VT, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, VCROSS)
XX("*", TIMES_X,#VT,120,#RT, #VT, 0, SAME2_D,ANGL_D, ANY_D, NIL_D, RVMUL)
XX("*", TIMES_X,#RT,120,#RT, #RT, 0, ANGL_D, ANGL_D, ANGL_D, NIL_D, RRMUL)
XX("*", TIMES_X,#VT,120,#TR, #VT, 0, SAME1_D,ANY_D, ANY_D, NIL_D, TVMUL)
XX("*", TIMES_X,#FRE,120,#TR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, TTMUL)
XX("*", TIMES_X,#TR,120,#TR, #TR, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TTMUL)
XX("MAX",MAX_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MAX)
XX("MIN",MIN_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MIN)
XX("DIV",DIV_X, #SC,120,#SC, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, DIV)
XX("MOD",MOD_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MOD)
XX("INT",INT_X, #SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, INT)
! note following is a kludgy way of making v wrt f = (rvmul (orient f) v) ;
XX("WRT",WRT_X, #VT,210,#VT, #RT, 0, SAME1_D,ANY_D, ANGL_D, NIL_D, RVMUL)
XX("→", ⊂→_X⊃, #TR,120,#FR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#FR, #TR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#TR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#TR, #TR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX(".", VDOT_X, #SC,120,#VT, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, VDOT)
XX("CONSTRUCT",CONSTRUCT_X,
#TR,123,#VT, #VT, #VT, DIST_D, DIST_D, DIST_D, DIST_D, CONSTR)
XX("SQRT",SQRT_X,#SC,100,#SC, 0, 0, SQRT_D, ANY_D, NIL_D, NIL_D,
⊂SSBRTN 1⊃)
XX("SIN", SIN_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 2⊃)
XX("COS", COS_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 3⊃)
XX("TAN", TAN_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 4⊃)
XX("ASIN",ASIN_X,#SC,100,#SC, 0, 0, ANGL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 5⊃)
XX("ACOS",ACOS_X,#SC,100,#SC, 0, 0, ANGL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 6⊃)
XX("ATAN2",ATAN2_X,#SC,120,#SC, #SC, 0, ANGL_D, ANY_D, SAME_D, NIL_D,
⊂SSBRTN 7⊃)
XX("LOG", LOG_X,#SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 8⊃)
XX("EXP", EXP_X,#SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 9⊃)
XX("/", SDIV_X, #SC,120,#SC, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, SDIV)
XX("/", SDIV_X, #VT,120,#VT, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, VSDIV)
XX("↑", STOS_X,#SC, 120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, STOS)
! XX("↑", EXPON_X,#SC, #SC, #SC, UNKN, ANY, NIL, $STOS) ;
! XX("SCALAR",⊂#sc+opc⊃, $SMAKE, #SC, 0, 0,SAME1,ANY,);
XX("VECTOR",⊂(#VT+OPC)⊃,#VT,123,#SC,#SC,#SC, SAME1_D,ANY_D, SAME_D,SAME_D, VMAKE)
XX("ROT",⊂(#RT+OPC)⊃, #RT,120,#VT, #SC, 0,ANGL_D, NIL_D, ANGL_D, NIL_D, AXW_ROTN)
XX("FRAME",⊂(#FR+OPC)⊃, #FRE,120,#RT, #VT, 0,DIST_D, ANGL_D, DIST_D, NIL_D, FMAKE)
XX("TRANS",⊂(#TR+OPC)⊃, #TR,120,#RT, #VT, 0,SAME2_D,ANGL_D, ANY_D, NIL_D, TMAKE)
⊃;
DEFINE #SC=SCALAR_VALUE, #VT=VECTOR_VALUE,#TR=TRANS_VALUE,#FR=FRAME_VALUE,#RT=ROT_VALUE,#FRE=FRAME_EXP_VALUE;
DEFINE SAME1_D=1,SAME2_D=2,SAME3_D=3,MULT_D=4,DIVID_D=5,ANGL_D=6,NIL_D=7,ANY_D=8,SAME_D=9,DIST_D=10,SQRT_D=11;
DEFINE XX_MAX=0;
DEFINE OPC=OP_COUNT;
DEFINE OPERATOR_COUNT=0;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =
⊂ REDEFINE OPERATOR_COUNT=OPERATOR_COUNT+1;
REDEFINE NEW_TOTAL= (((OPXXX*#NTYPE+#T1)*#NTYPE+#T2)*#NTYPE+#T3)
*#NTYPE;
IFC XX_MAX>NEW_TOTAL THENC
REQUIRE CRLF&"DISORDERED "&OPQ&CVS(OPXXX) MESSAGE;
ELSEC
REDEFINE XX_MAX = NEW_TOTAL ; ENDC⊃;
OPERATIONS;
REDEFINE OPERATOR_COUNT=0;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =
⊂ REDEFINE OPERATOR_COUNT=OPERATOR_COUNT+1;
REDEFINE NEW_TOTAL= (((OPXXX*#NTYPE+#T1)*#NTYPE+#T2)*#NTYPE+#T3)
*#NTYPE;
NEW_TOTAL, ⊃;
PRELOAD_ARRAY(OCODE,OPERATIONS,INTEGER,1,OPERATOR_COUNT);
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =⊂"STR",⊃;
PRELOAD_ARRAY(SCODE,OPERATIONS,STRING,1,OPERATOR_COUNT);
DEFINE #NDTYPE=20,#NOTYPE=1000;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =⊂
REDEFINE XX_TEMP= ((((#TYR*#NDTYPE+#DR)*#NDTYPE+#D1)*#NDTYPE+#D2)
*#NDTYPE+#D3)*#NOTYPE+OPR;
XX_TEMP,⊃;
PRELOAD_ARRAY(INFO,OPERATIONS,INTEGER,1,OPERATOR_COUNT);
PRESET_WITH "SCALAR","VECTOR","ROT","FRAME","PLANE","TRANS","EVENT","ATOM","WORLD","LABEL";
STRING ARRAY DTYPE[1:10];
PRELOAD_WITH EQV_RES,OR_RES,AND_RES,ORDER_RES,ADD_RES,MULT_RES,WRT_RES;
INTEGER ARRAY RESCL[0:6];
! P_EXP2_BASIC, OPCODE, ERROR HANDLER ;
BOOLEAN PROCEDURE P_EXP2_BASIC;
α RPTR(EXPR)$$1; LABEL DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
RPTR(ANY_CLASS) PROCEDURE ERROR(INTEGER I; STRING S);
α RPTR(ANY_CLASS) R1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
RETURN(R1);
β;
RPTR (EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(EXPR)R);
α STRING S; INTEGER I,INDEX;
RPTR(ANY_CLASS) E1,R1;
RPTR(DIMENS_EXPONENT) ARRAY D[1:3],E[1:3];
STRING ARRAY S1[1:4];
INTEGER ARRAY T[0:4],T1[1:3];
INTEGER TYPOR,DIMR,TYPER;
INTEGER ARRAY DIMINFO[1:3];
INTEGER J;
T[0]←OP; R1←R;
FOR I←1 STEP 1 UNTIL 4 DO T[I]←0;
FOR I←1 STEP 1 UNTIL NARGS MIN 4 DO
α IF (T[I]←EXPR:TYPE[R1])=0
THEN RETURN(MK_EXPR(NULL,0,NULL_RECORD));
R1←EXPR:NEXT[R1]; β;
IF (INDEX←MATINX(FUNC(T),OCODE,1,OPERATOR_COUNT))=0 THEN
α STRING S,S1; S←DTYPE[T[1]];
FOR I← 2 STEP 1 UNTIL NARGS MIN 4 DO
IF T[I]≠0 THEN S←S&", "&DTYPE[T[I]];
IF OP≤OP_COUNT THEN S1←OPERATORS[OP] ELSE
S1←DTYPE[OP-OP_COUNT];
ERROR(5000,"OPERATOR/function "&S1&" CANNOT TAKE OPERANDS/arguments "
&S&CRLF&"CONTINUE WILL GIVE NULL EXPRESSION");
RETURN(MK_EXPR(NULL,0,NULL_RECORD));
β;
I←INFO[INDEX];
J← #NOTYPE;
TYPOR←I MOD J; I← I DIV J;
J←#NDTYPE;
DIMINFO[3]←I MOD J; I←I DIV J;
DIMINFO[2]←I MOD J; I←I DIV J;
DIMINFO[1]←I MOD J; I←I DIV J;
J←#NDTYPE;
DIMR←I MOD J; TYPER←I DIV J;
T1[1]←TYPOR DIV 100;
T1[2]←(TYPOR DIV 10)MOD 10;
T1[3]←TYPOR MOD 10;
R1←R; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
IF R1≠NULL_RECORD THEN
α
STRING SSS;
SSS←(IF OP≤OP_COUNT THEN OPERATORS[OP] ELSE
DTYPE[OP-OP_COUNT]);
D[I]←EXPR:DIMEN[R1];
S1[I]←EXPR:BODY[R1];
R1←EXPR:NEXT[R1];
CASE DIMINFO[I] OF
α
[ANY_D] E[I]←D[I];
[SAME_D] CHECK_DIMENSIONS("arguments "&CVS(I)&","&CVS(I-1)&" of"&sss,
D[I],E[I]←E[I-1]);
[DIST_D] CHECK_DIMENSIONS("requirement of DISTANCE dimension"&
crlf&" on argument "&cvs(i)&" of "&sss,D[I],DISTANCE_DIMENS);
[ANGL_D] CHECK_DIMENSIONS("requirement of ANGLE dimension"&
crlf&" on argument "&cvs(i)&" of "&sss,D[I],ANGLE_DIMENS);
[NIL_D] CHECK_DIMENSIONS("requirement of DIMENSIONLESS dimension"&
crlf&" or argument "&cvs(i)&" of "&sss,D[I],NIL_DIMENS)
β;
β ELSE DONE;
CASE DIMR OF
α
[SAME1_D] E1←D[1];
[SAME2_D] E1←D[2];
[SAME3_D] E1←D[3];
[MULT_D] E1←MULTIPLY_DIMENSIONS(D[1],D[2]);
[DIVID_D] E1←DIVIDE_DIMENSIONS(D[1],D[2]);
[DIST_D] E1←DISTANCE_DIMENS;
[ANGL_D] E1←ANGLE_DIMENS;
[NIL_D] E1←NIL_DIMENS;
[SQRT_D] E1←SQRT_DIMENSIONS(D[1]);
ELSE ERROR(50000,"PARSER ERROR IN DIMENSION DETERMINATION")
β;
FOR I←1 STEP 1 UNTIL NARGS DO S←S&" "&S1[T1[I]];
RETURN(MK_EXPR("( $"&SCODE[INDEX]&S&")",TYPER,E1));
β;
! exp,bfact,bterm,aexp,term,factor;
IFC FALSE THENC
EXP E: BFF | BFF ≡ BFF
BEFACT BFF: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE EXP;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BEFACT;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BFACT;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BTERM;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE AEXP;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE TERM;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE PF;
! EXP E: BFF | BFF ≡ BFF ;
%%% RECURVISE RPTR(EXPR) PROCEDURE EXP;
%%% α RPTR(EXPR)$$1,$$2;
%%% $$1←BEFACT;
%%% IF TYPE_OF_RES_WORD = EQV_RES THEN
%%% α INTEGER I; I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1]←BEFACT;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%%
%%% ! BEFACT BFF: BF { OR BF } ;
%%%
%%% RECURSIVE RPTR(EXPR) PROCEDURE BEFACT;
%%% α RPTR(EXPR)$$1,$$2;
%%% $$1←BFACT;
%%% WHILE TYPE_OF_RES_WORD=OR_RES DO
%%% α INTEGER I; I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1] ← BFACT;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%%
%%% ! BFACT BF: BT { AND BT } ;
%%% RECURSIVE RPTR(EXPR) PROCEDURE BFACT;
%%% α RPTR(EXPR)$$1,$$2;INTEGER I1,I2;
%%% $$1←BTERM;
%%% WHILE TYPE_OF_RES_WORD=AND_RES DO
%%% α INTEGER I; I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1]←BTERM;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%% ! BTERM BT: AE | AE <REL> AE ;
%%% RECURSIVE RPTR(EXPR) PROCEDURE BTERM;
%%% α RPTR(EXPR)$$1,$$2;
%%% $$1←AEXP;
%%% IF TYPE_OF_RES_WORD = ORDER_RES THEN
%%% α INTEGER I; I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1]←AEXP;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%% ! AEXP AE: {+|-} T {+|- T } ;
%%% RECURSIVE RPTR(EXPR) PROCEDURE AEXP;
%%% α RPTR(EXPR) $$1,$$2; INTEGER I;
%%% IF TYPE_OF_RES_WORD = ADD_RES THEN
%%% α I←SPECIAL_INFO;
%%% GET_TOKEN; $$1←TERM;
%%% $$1←OPCODE(I,1,$$1);
%%% β
%%% ELSE $$1←TERM;
%%% WHILE TYPE_OF_RES_WORD = ADD_RES DO
%%% α I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1]←TERM;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%% ! TERM T: F {*|/ F} ;
%%% RECURSIVE RPTR(EXPR) PROCEDURE TERM;
%%% α RPTR(EXPR) $$1,$$2; INTEGER I;
%%% $$1←FACTOR;
%%% WHILE TYPE_OF_RES_WORD = MULT_RES DO
%%% α I←SPECIAL_INFO;
%%% GET_TOKEN; EXPR:NEXT[$$1]←FACTOR;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%% ! FACTOR F: PF or PF↑PF or PF WRT PF or PF→PF ;
%%% RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
%%% α RPTR(EXPR) $$1,$$2; INTEGER I;
%%% $$1←PF;
%%% IF TYPE_OF_RES_WORD = WRT_RES THEN
%%% α I←SPECIAL_INFO; GET_TOKEN;
%%% ! Following is a kludge because v WRT f goes to (RVMUL (ORIENT f) v);
%%% IF I≠WRT_X THEN EXPR:NEXT[$$1]←PF
%%% ELSE α $$2←PF;
%%% EXPR:NEXT[$$1]←OPCODE(ORIENT_X,1,$$2);
%%% β;
%%% $$1←OPCODE(I,2,$$1);
%%% β;
%%% RETURN($$1);
%%% β;
%%% ! PFACTOR PF: ( E ),
%%% f(E,E,E,..)
%%% <constant>,
%%% <id>,
%%% ¬ PF;
%%% RECURSIVE RPTR(EXPR) PROCEDURE PF;
%%% α RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
%%% CASE TYPE_OF_TOKEN OF
%%% α
%%% [NUMERIC_TOKEN]
%%% α
%%% $$1←MK_EXPR(TOKEN,SCALAR_VALUE,NIL_DIMENS);
%%% GET_TOKEN;
%%% β;
%%%
%%% [ID_TOKEN]
%%% α
%%% $$1←MK_EXPR(TOKEN,ID_TYPE,ID_LIST:DIMEN[TOKEN_PTR]);
%%% GET_TOKEN;
%%% β;
%%% [RESERVED_TOKEN]
%%% CASE TYPE_OF_RES_WORD OF
%%% α
%%% [abs_res]
%%% α GET_TOKEN; $$1←EXP;I←SPECIAL_INFO;
%%% IF TOKEN≠"|"
%%% THEN ERROR_REJECT(150,"MISMATCHED VERT BAR, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% $$1←OPCODE(I,1,$$1);
%%% β;
%%% [func_res]
%%% α I← SPECIAL_INFO;
%%% GET_TOKEN;
%%% IF TOKEN≠"("
%%% THEN ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% $$2←$$1←EXP; I2←1;
%%% WHILE TOKEN="," DO
%%% α GET_TOKEN; $$3←EXP; I2←I2 + 1;
%%% $$2←(EXPR:NEXT[$$2]←$$3);
%%% β;
%%% IF TOKEN≠")"
%%% THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% $$1←OPCODE(I,I2,$$1);
%%% β;
%%% [declare_res]
%%% α I← SPECIAL_INFO + op_count;
%%% GET_TOKEN;
%%% IF TOKEN≠"("
%%% THEN ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% $$2←$$1←EXP; I2←1;
%%% WHILE TOKEN="," DO
%%% α GET_TOKEN; $$3←EXP; I2←I2 + 1;
%%% $$2←(EXPR:NEXT[$$2]←$$3);
%%% β;
%%% IF TOKEN≠")"
%%% THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% $$1←OPCODE(I,I2,$$1);
%%% β;
%%% [OPEN_PAREN_RES]
%%% α GET_TOKEN; $$1←EXP;
%%% IF TOKEN≠")"
%%% THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
%%% ELSE GET_TOKEN;
%%% β;
%%% [NOT_RES]
%%% α I←SPECIAL_INFO; GET_TOKEN;
%%% $$1←EXP;
%%% $$1←OPCODE(I,1,$$1);
%%% β;
%%% [OR_res]
%%% α
%%% $$1←MK_EXPR(CURRENT_FRAME,
%%% FRAME_VALUE,DISTANCE_DIMENS);
%%% GET_TOKEN;
%%% β;
%%% [MISC_RES]
%%% IF EQU(TOKEN,"INSCALAR")
%%% THEN α
%%% $$1←MK_EXPR("($SCALARD)",SCALAR_VALUE, NIL_DIMENS);
%%% GET_TOKEN;
%%% β
%%% ELSE IF EQU(TOKEN,"QUERY")
%%% THEN α
%%% STRING S;
%%% S←"($QUERY ";
%%% GET_TOKEN;
%%% IF TOKEN≠"(" THEN ERROR_REJECT(161,"need ( after QUERY");
%%% DO α
%%% GET_TOKEN;
%%% IF TYPE_OF_TOKEN=STRING_TOKEN THEN
%%% α S←S&TOKEN&" "; GET_TOKEN; β
%%% ELSE α $$1←EXP;
%%% S←S&EXPR:BODY[$$1]&" ";
%%% β;
%%% IF TOKEN≠"," AND TOKEN ≠")" THEN
%%% ERROR(162,"need , between arguments of QUERY");
%%% β UNTIL TOKEN=")";
%%% $$1←MK_EXPR(S,SCALAR_VALUE, NIL_DIMENS);
%%% β
%%% ELSE α ERROR(160,"UNEXPECTED TOKEN FOUND IN MISC_RES :"&TOKEN);
%%% $$1←MK_EXPR(NULL,0,NULL_RECORD);
%%% β;
%%% ELSE α ERROR(170,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will return null expression");
%%% $$1←MK_EXPR(NULL,0,NULL_RECORD);
%%% β
%%% β;
%%% ELSE α ERROR(180,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will give null expression");
%%% $$1←MK_EXPR(NULL,0,NULL_RECORD);
%%% β
%%% β;
%%% RETURN($$1);
%%% β;
ELSEC
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP="(XXXXX(0))";
DEFINE EXP_XX=0,BEFACT_XX=1,BFACT_XX=2,BTERM_XX=3,AEXP_XX=4,TERM_XX=5,FACTOR_XX=6,
PF_XX=7;
! FORWARD RECURSIVE RPTR(EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE PF XXXXX(PF_XX);
RECURSIVE RPTR(EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND TYPE_OF_RES_WORD = ADD_RES THEN
α I←SPECIAL_INFO;
GET_TOKEN; $$1←XXXXX(LEVEL + 1);
$$1←OPCODE(I,1,$$1);
β
ELSE $$1←XXXXX(LEVEL+1);
WHILE TYPE_OF_RES_WORD=RESCL[LEVEL] DO
α I←SPECIAL_INFO;
GET_TOKEN; EXPR:NEXT[$$1] ← XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[EXP_XX] [BTERM_XX]
α
$$1←XXXXX(LEVEL + 1);
IF TYPE_OF_RES_WORD = RESCL[LEVEL] THEN
α I←SPECIAL_INFO;
GET_TOKEN; EXPR:NEXT[$$1]←XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF TYPE_OF_RES_WORD = WRT_RES THEN
α I←SPECIAL_INFO; GET_TOKEN;
! Following is a kludge because v WRT f goes to (RVMUL (ORIENT f) v);
IF I≠WRT_X THEN EXPR:NEXT[$$1]←XXXXX(LEVEL + 1)
ELSE α $$2←XXXXX(LEVEL + 1);
EXPR:NEXT[$$1]←OPCODE(ORIENT_X,1,$$2);
β;
$$1←OPCODE(I,2,$$1);
β;
β;
[PF_XX]
CASE TYPE_OF_TOKEN OF
α
[NUMERIC_TOKEN]
α
$$1←MK_EXPR(TOKEN,SCALAR_VALUE,NIL_DIMENS);
GET_TOKEN;
β;
[ID_TOKEN]
α
$$1←MK_EXPR(TOKEN,ID_TYPE,ID_LIST:DIMEN[TOKEN_PTR]);
GET_TOKEN;
β;
[ARRAY_TOKEN]
α RPTR(ARRAY_LIST) APTR; INTEGER NARGS,ARGS; STRING S;
APTR←TOKEN_PTR; S←"$AREF "&TOKEN;
GET_TOKEN;
IF TOKEN≠"[" THEN ERROR_reject(51,"need a [ after array variable,continue will insert");
GET_TOKEN;
NARGS←arrAy_LIST:#DIMENS[APTR];
FOR ARGS←1 STEP 1 UNTIL NARGS DO
α
$$1←EXP;
CHECK_DIMENSIONS("field of array variable, which should be dimensionless",
nil_dimens, expr:dimen[$$1]);
if expr:type[$$1]≠scalar_value then
error(51,"field of array variable should be a scalar expression");
if args≠nargs and token≠"," then
error_reject(52,"need , between arguments of a array variable")
else if args=nargs and token≠"]" then
error_reject(52,"need ] after last argument of a array variable");
s←s&" "&expr:body[$$1];
get_token;
β;
$$1←mk_expr("("&s&")",array_list:type[aptr],array_list:dimen[aptr]);
β;
[PROCEDURE_TOKEN]
α string s; integer ttype;
rptr(procedure_list)pptr; integer nargs,args;
pptr←token_ptr; s←"$CALL "&TOKEN;
get_token;
IF (nargs← procedure_list:#args[pptr])≠0
then
α
if token≠"(" then error_reject(54,"need ( here for procedure");
get_token;
for args←1 step 1 until nargs do
α
if procedure_list:isid[pptr][args]
then α
ttype←id_list:type[procedure_list:args[pptr][args]];
$$1←exp;
β
else α
ttype←array_list:type[procedure_list:args[pptr][args]];
if type_of_token≠array_token
then error(53,"need array name here");
$$1←MK_EXPR(TOKEN,array_list:type[token_ptr],
array_list:dimen[token_ptr]);
get_token;
β;
if ttype≠expr:type[$$1]
then error(53,"argument "&cvs(args)&" of procedure does not have same type as declared");
check_dimensions("argument "&cvs(args) &" of procedure",
(if procedure_list:isid[pptr][args] then
id_list:dimen[procedure_list:args[pptr][args]] else
array_list:dimen[procedure_list:args[pptr][args]]),
expr:dimen[$$1]);
if args≠nargs and token≠","
then error_reject(54,"need , to separate arguments of a procedure")
else if args=nargs and token≠")"
then error_reject(52,"need ) after last argument of procedure call");
get_token;
s←s&" "&expr:body[$$1];
β;
β;
$$1←mk_expr("("&s&")",procedure_list:type[pptr],
procedure_list:dimen[pptr]);
β;
[RESERVED_TOKEN]
CASE TYPE_OF_RES_WORD OF
α
[abs_res]
α GET_TOKEN; $$1←EXP;I←SPECIAL_INFO;
IF TOKEN≠"|"
THEN ERROR_REJECT(150,"MISMATCHED VERT BAR, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,1,$$1);
β;
[func_res]
α I← SPECIAL_INFO;
GET_TOKEN;
IF TOKEN≠"("
THEN ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GET_TOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,I2,$$1);
β;
[declare_res]
α I← SPECIAL_INFO + op_count;
GET_TOKEN;
IF TOKEN≠"("
THEN ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GET_TOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,I2,$$1);
β;
[DEPROACH_res]
α
GET_token;
IF token≠"("
THEN ERROR_REJECT(161,"REQUIRE LEFT PAREN AFTER DEPROACH, WILL INSERT")
ELSE GET_TOKEN;
$$1←EXP;
IF EXPR:TYPE[$$1]≠TRANS_VALUE THEN
ERROR(162,"Can have deproach only for a frame");
IF TOKEN≠")"
THEN ERROR_REJECT(163,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←MK_EXPR("($DEPROACH "&EXPR:BODY[$$1]&" )",
TRANS_VALUE,DISTANCE_DIMENS);
β;
[OPEN_PAREN_RES]
α GET_TOKEN; $$1←EXP;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
β;
[NOT_RES]
α I←SPECIAL_INFO; GET_TOKEN;
$$1←EXP;
$$1←OPCODE(I,1,$$1);
β;
[OR_res]
α
IF NOT EQU(CURRENT_FRAME,NULL) THEN
$$1←MK_EXPR(CURRENT_FRAME,
trans_VALUE,DISTANCE_DIMENS)
ELSE
BEGIN
ERROR(165," ⊗ is undefined in this expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
END;
GET_TOKEN;
β;
[MISC_RES]
IF EQU(TOKEN,"INSCALAR")
THEN α
$$1←MK_EXPR("($SCALRD)",SCALAR_VALUE, NIL_DIMENS);
GET_TOKEN;
β
ELSE IF EQU(TOKEN,"QUERY")
THEN α
STRING S;
S←"($QUERY ";
GET_TOKEN;
IF TOKEN≠"(" THEN ERROR_REJECT(161,"need ( after QUERY");
DO α
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN THEN
α S←S&dquote&TOKEN&dquote&" "; GET_TOKEN; β
ELSE α $$1←EXP;
S←S&EXPR:BODY[$$1]&" ";
β;
IF TOKEN≠"," AND TOKEN ≠")" THEN
ERROR(162,"need , between arguments of QUERY");
β UNTIL TOKEN=")";
S←S&")";
$$1←MK_EXPR(S,SCALAR_VALUE, NIL_DIMENS);
GET_TOKEN;
β
ELSE α ERROR(160,"UNEXPECTED TOKEN FOUND IN MISC_RES :"&TOKEN);
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β;
ELSE α ERROR(170,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will return null expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β
β;
ELSE α ERROR(180,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will give null expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β
β
β;
RETURN($$1);
β;
ENDC
! exp2 starts here, p_exp_basic;
GET_TOKEN;
OUTEXPR←EXPR:BODY[$$1←EXP];
REJECT←TRUE;EXP_TYPE←EXPR:TYPE[$$1];
EXP_DIMENS←EXPR:DIMEN[$$1];
RETURN(TRUE);
DONEP:RETURN(FALSE);
β;
BOOLEAN PROCEDURE P_EXP_BASIC;
α
BOOLEAN B1;
IF (B1←P_EXP2_BASIC)=TRUE THEN PRINT(OUTEXPR);
RETURN(B1);
β;
! P_condition;
BOOLEAN PROCEDURE P_CONDITION_BASIC(INTEGER PP;STRING PRELUDE);
! returns true if successful, false otherwise;
α STRING COND,OP; LABEL FLUSH; RPTR(DIMENS_EXPONENT)PTR;
LABEL DONEP;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GO TO FLUSH;
β;
PROCEDURE P_EXP2; IF P_EXP2_BASIC=FALSE THEN GOTO DONEP;
PROCEDURE P_EXP; IF P_EXP_BASIC=FALSE THEN GOTO DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
return(r1);
β;
GET_TOKEN;
IF ID_TYPE=event_Value THEN
α PRINT(PRELUDE& " " & TOKEN);
RETURN(TRUE);
β;
IF TYPE_OF_RES_WORD=cm_RES or equ(token,"FORCE") OR EQU(TOKEN,"TORQUE") THEN
α "CM_RES"
INTEGER FORCE_TYPE;
IF SPECIAL_INFO=nil_CM
THEN COND←TOKEN
ELSE
α ! YOU MIGHT WANT TO INCORPORATE ALL OF THIS INTO P_EXP2;
FORCE_TYPE←SPECIAL_INFO;
if force_type=torque_CM or force_type=force_cm
then
α COND←"FORCE "; GET_TOKEN;
IF FORCE_TYPE=TORQUE_CM THEN PTR←TORQUE_DIMENS ELSE PTR←FORCE_DIMENS;
IF EQU(TOKEN,"(")
THEN
α "("
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&" "&OUTEXPR; GET_TOKEN;
IF ¬EQU(TOKEN,")")
THEN ERROR(1201,"Need right paren here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_RES_WORD≠ORDER_RES
THEN ERROR(1202,"Need relational operator here");
IF TOKEN_EQU("≤")
THEN α
ERROR(1202,"Need < here instead of ≤, continue will assume < ");
token←"<";
β
ELSE IF TOKEN_EQU(">")
THEN α
ERROR(1203,"Need ≥ here instead of >, continue will assume ≥ ");
TOKEN←"≥";
β;
PRINT(PRELUDE&" ($"&COND& " "&token); SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Force or Torque condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
if force_type=force_cm
then PRINT(" + )")
else if force_type=torque_cm then print(" - )") ELSE PRINT (" )");
SPACING←SPACING-1; RETURN(TRUE);
β "("
ELSE
IF TYPE_OF_RES_WORD=ORDER_RES
THEN
α "="
STRING REL_OP, SCAL_EXP,VECT_EXP,FFFF,PLUS_MIN;
REL_OP←TOKEN;
IF TOKEN_EQU("≤")
THEN α
ERROR(1202,"Need < here instead of ≤, continue will assume < ");
rel_op←"<";
β
ELSE IF TOKEN_EQU(">")
THEN α
ERROR(1203,"Need ≥ here instead of >, continue will assume ≥ ");
REL_OP←"≥";
β;
IF FORCE_TYPE=FORCE_CM THEN PLUS_MIN ← " + " ELSE PLUS_MIN←" - ";
P_EXP2; FFFF←null;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Force or Torque condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
SCAL_EXP←OUTEXPR; GET_TOKEN;
IF ¬TOKEN_EQU("ALONG","ABOUT")
THEN
α if ¬token_equ("WITH","ON",";")
THEN ERROR(1205,"Need ALONG or ABOUT here, continue will insert it.");
REJECT←TRUE;
β
ELSE
α P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(Vector_value, Nil_dimens,"direction vector")
then error(48, "Need vector expression here");
vect_exp←outexpr; GET_TOKEN;
IF ¬TOKEN_EQU("OF") THEN REJECT←TRUE
ELSE
α P_EXP2;
IF EXP_TYPE≠TRANS_VALUE AND EXP_TYPE≠ROT_VALUE
THEN ERROR(1206, "Need frame or rot value here");
FFFF←"($FORCE_FRAME "&outexpr; GET_TOKEN;
IF ¬TOKEN_EQU("IN")
THEN α REJECT←TRUE; FFFF←FFFF& " # )"; β
ELSE
α GET_TOKEN;
IF TOKEN_EQU("WORLD","STATION","FIXED")
THEN FFFF←FFFF & " # )"
ELSE
IF TOKEN_EQU("HAND","BHAND","YHAND","MOVING")
THEN FFFF←FFFF& " ⊗ )"
ELSE
α ERROR(1209, "Need FIXED or MOVING here, Continue will treat as station");
FFFF←FFFF&" # )";
β;
GET_TOKEN;
if ¬token_equ("COORD","COORDS","COORDINATES")
THEN REJECT←TRUE;
β;
β;
β;
print(PRELUDE);
PRINT("($"&COND& " "&VECT_EXP&" "
& REL_OP & " " & SCAL_EXP& " "&
PLUS_MIN & FFFF& " )");
β "="
ELSE ERROR(1204, "Need relational operator here");
β
ELSE
IF FORCE_TYPE=duration_CM
THEN
α PTR←TIME_DIMENS; cond← "DURATION "; GET_TOKEN;
PRINT(PRELUDE&" ($"&COND& " "&token);
SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Duration condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
PRINT (" )"); SPACING←SPACING-1; RETURN(TRUE);
β
ELSE
α ERROR(1203, "Only force or torque condition monitor allowed");
print(" )");
β;
β;
β "CM_RES"
ELSE
α REJECT←TRUE; P_EXP2;
IF EXP_TYPE≠boole_Value and EXP_TYPE≠scalar_VALUE
THEN F_STATE(44, "Need boolean expression or force_type predicate in condition monitor");
PRINT(PRELUDE); print(outexpr); return(TRUE);
β;
FLUSH: RETURN(TRUE);
DONEP: RETURN(FALSE);
β;
! P_clauses, T_gen;
BOOLEAN recursive PROCEDURE P_CLAUSES_BASIC;
α "P_CLAUSES"
BOOLEAN T; LABEL FLUSH; BOOLEAN ICMT;STRING LABL; INTEGER LAB_TYPE;
LABEL DONEP;
PROCEDURE P_EXP; IF P_EXP_BASIC=FALSE THEN GOTO DONEP;
PROCEDURE P_EXP2; IF P_EXP2_BASIC=FALSE THEN GOTO DONEP;
PROCEDURE P_CONDITION(INTEGER II; STRING SS); IF P_CONDITION_BASIC(II,SS)=FALSE THEN GOTO DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
return(r1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
ICMT←INSIDE_CONDITION_MONITOR;
T←TRUE; GET_TOKEN;
WHILE T DO
α
LABL←NULL;
IF (LAB_TYPE←ID_TYPE)=LABEL_VALUE
THEN IF DEFINED(TOKEN_PTR)
THEN ERROR(123,TOKEN& " already used.")
ELSE
α DEFIN(TOKEN_PTR); LABL←TOKEN&" ";
INSIDE_CONDITION_MONITOR←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN ERROR(23,"Need colon after label " & LABL & " .") ELSE GET_TOKEN;
β;
IF (TYPE_OF_RES_WORD=on_RES)
THEN
α
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN P_CONDITION(2,"( "&LABL& "$ON +")
ELSE α CHECK_NEXT_TOKEN(37, NULL,"ON"); P_CONDITION(2,"( " & LABL& "$ON -"); β;
SPACING←SPACING+1;GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β
ELSE IF EQU(TOKEN,"(") THEN
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1; TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="("
THEN C←C+1
ELSE IF BRCHAR=")"
THEN C←C-1
ELSE α PRINT(TEMP); TEMP←NULL; β;
β;
PRINT(TEMP); GET_TOKEN;
β
ELSE IF ¬(move_beg ≤ TYPE_OF_RES_WORD ≤ move_end) THEN
α
! END OF MOVE STATEMENT FOUND;
REJECT←TRUE; T←FALSE;
β
ELSE CASE TYPE_OF_RES_WORD - move_beg OF
α
[via_X] α ! VIA CLAUSE FOUND;
PRINT("($VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
GET_TOKEN;
IF EQU(TOKEN,",") THEN
α SPACING←SPACING-1; PRINT(")");
WHILE EQU(TOKEN,",") DO
α
PRINT("($VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β;
β
ELSE α BOOLEAN V_FOUND,D_FOUND,CONTIN; CONTIN←TRUE;
IF EQU(TOKEN,"WHERE") THEN
WHILE ¬(V_FOUND ∧ D_FOUND) ∧ CONTIN DO
α
GET_TOKEN;
IF V_FOUND ∧ EQU(TOKEN,"VELOCITY") THEN
F_STATE(3011,"Multiple VELOCITY specification found in WITH clause.")
ELSE IF EQU(TOKEN,"VELOCITY") THEN
α PRINT("($VELOCITY "); GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3014,"Need = here.");
SPACING←SPACING+1; P_EXP;
SPACING←SPACING-1; PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(vector_VALUE,VELOCITY_DIMENS,
"Velocity expression") THEN
α
SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a vector expression here.");
β;
V_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE IF D_FOUND ∧ EQU(TOKEN,"DURATION") THEN
F_STATE(3013,"Multiple DURATION specification found in WITH clause.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("($DURATION " & TOKEN & " ");
SPACING←SPACING+1;P_EXP;SPACING←SPACING-1;
PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE, TIME_DIMENS,
"DUARATION clause")THEN
α SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a scalar expression here.");
β;
D_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE CONTIN←FALSE;
β;
IF EQU(TOKEN,"THEN") THEN
α PRINT("($THEN"); SPACING←SPACING+1; P_STATEMENT; SPACING←SPACING-1;
PRINT(")");GET_TOKEN;
β;
SPACING←SPACING-1; PRINT(")");
β;
β;
[directly_X] α
PRINT ("($ARRIVAL NILDEPROACH)");
PRINT ("($DEPARTURE NILDEPROACH)");get_token;
β;
ELSE α REJECT←TRUE; T←FALSE; β;
[with_X] α;
GET_TOKEN;
IF TYPE_OF_RES_WORD=approach_RES THEN
α "APPROACH_RES"
if equ(token,"ARRIVAL")
then ERROR(-1,"Use APPROACH instead of ARRIVAL")
else if equ(token,"APPROACH") then token←"ARRIVAL";
PRINT("($" & TOKEN); SPACING←SPACING+1; GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022,"Need = here.");
GET_TOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN PRINT("NILDEPROACH")
ELSE IF EQU(TOKEN,"DEPROACH") THEN
α
PRINT("($DEPR"); SPACING←SPACING+1; GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(3019,"Need left paren here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(frame_exp_VALUE,DISTANCE_DIMENS,
"FRAME expression")
THEN F_STATE(3020,"Need frame exp here.");
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN ERROR_REJECT(3021,"Need right paren here.");
SPACING←SPACING-1; PRINT(")");
β
ELSE α
REJECT←TRUE;P_EXP;
IF EXP_TYPE≠scalar_VALUE ∧ EXP_TYPE≠vector_VALUE ∧ EXP_TYPE≠trans_VALUE THEN
ERROR(3018,"Type mismatch for DEPROACH.");
β;
SPACING←SPACING-1; PRINT(")");
β "APPROACH_RES"
ELSE IF EQU(TOKEN,"WOBBLE") THEN
α "WOBBLE"
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022, "Need = here.");
PRINT("($WOBBLE "); SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE, ANGLE_DIMENS,
"WOBBLE Clause")
THEN F_STATE(3012,"Need a scalar expression here.");
SPACING←SPACING - 1;PRINT(")");
β "WOBBLE"
ELSE IF EQU(TOKEN,"FORCE") OR EQU(TOKEN, "TORQUE")
THEN α REJECT←TRUE; P_CONDITION(2,NULL); β
ELSE IF EQU(TOKEN,"DURATION") THEN
α;
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("($DURATION " & TOKEN & " ");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,TIME_DIMENS,
"DURATION clause")
THEN F_STATE(3012,"Need a scalar expression here.");
β
ELSE IF EQU(TOKEN,"SPEED_FACTOR") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(3014,"Need = here.");
P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,NIL_DIMENS,
"DURATION clause")
THEN F_STATE(3012,"Need a scalar expression here.");
PRINT("($SPEED_FACTOR "& OUTEXPR & " )");
β
ELSE IF EQU(TOKEN,"NO_NULLING") THEN PRINT("($NNULL +)")
ELSE IF EQU(TOKEN,"NULLING") THEN PRINT("($NNULL -)")
ELSE IF EQU(TOKEN,"RTMOVE") THEN PRINT("($RTMOVE)")
ELSE IF EQU(TOKEN,"FORCE_FRAME") THEN
α
STRING FFFF;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(3014,"Need = here.");
P_EXP2;
IF EXP_TYPE≠trans_VALUE and EXP_TYPE≠rot_VALUE THEN
ERROR(3012,"Need a trans or rot expression here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"IN") THEN error_REJECT(46,"Need IN here, will insert it");
GET_TOKEN;
IF TOKEN_EQU("STATION","TABLE","WORLD","FIXED") THEN
FFFF←" #"
ELSE IF TOKEN_EQU("HAND","BHAND","YHAND","MOVING")
THEN FFFF←" ⊗" ELSE FFFF←NULL;
PRINT("($FORCE_FRAME " & OUTEXPR & FFFF & " )");
get_token;
IF ¬TOKEN_EQU("COORD","COORDS","COORDINATED") THEN REJECT←TRUE;
β
ELSE F_STATE(3016,"Illegal WITH clause.");
GET_TOKEN;
β
β;
if id_type=label_value then t←true; ! patched;
β;
FLUSH: INSIDE_CONDITION_MONITOR←ICMT; RETURN(TRUE);
DONEP: RETURN(FALSE);
β "P_CLAUSES";
STRING PROCEDURE T_GEN;
α
T_COUNT←T_COUNT+1;
RETURN("_T"&CVS(T_COUNT));
β;
! P_statement, F_state, modify_continue, modify_flush;
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
LABEL GLOBAL_RE_TRY;
LABEL FLUSH,TRY_AGAIN; STRING LABL; INTEGER LABEL_TYPE;
RPTR(DIMENS_EXPONENT) DIM_PTR;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO GLOBAL_RE_TRY; β;
return(r1);
β;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO GLOBAL_RE_TRY; β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO GLOBAL_RE_TRY; β;
RETURN(B1);
β;
PROCEDURE P_EXP;
IF P_EXP_BASIC=FALSE THEN GOTO GLOBAL_RE_TRY;
PROCEDURE P_EXP2;
IF P_EXP2_BASIC=FALSE THEN GOTO GLOBAL_RE_TRY;
RCLASS ID_PROP( STRING STOKEN; INTEGER TYPE,id_CLASS; RANY TPTR);
RPTR(ID_PROP)PROCEDURE GET_ID;
BEGIN
RPTR(ID_PROP)IDX;
GET_TOKEN;
IF TYPE_OF_TOKEN = ID_TOKEN THEN
α IDX←NEW_RECORD(ID_PROP);
ID_PROP:STOKEN[IDX]←TOKEN;
ID_PROP:TYPE[IDX]←ID_TOKEN;
ID_PROP:ID_CLASS[IDX]←ID_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
β
ELSE
IF TYPE_OF_TOKEN = ARRAY_TOKEN THEN
α
IDX←NEW_RECORD(ID_PROP);
ID_PROP:TYPE[IDX]←ARRAY_TOKEN;
ID_PROP:ID_CLASS[IDX]←ARRAY_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
REJECT←TRUE;
P_EXP2;
ID_PROP:STOKEN[IDX]←OUTEXPR;
β
ELSE ERROR(12,"need either simple or array identifier here");
RETURN(IDX);
END;
PROCEDURE P_CONDITION(INTEGER PP;STRING PRELUDE);
IF P_CONDITION_BASIC(PP,PRELUDE)=FALSE THEN GOTO GLOBAL_RE_TRY;
PROCEDURE P_CLAUSES;
IF P_CLAUSES_BASIC=FALSE THEN GOTO GLOBAL_RE_TRY;
PROCEDURE F_STATE(VALUE INTEGER PP,IP(-10000); VALUE STRING SP(NULL));
α STRING CLOSE; INTEGER I; CLOSE←NULL;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
IF SP≠NULL THEN ERROR(IP,SP&crlf&"Continue will flush statement.")
else outstr(CRLF&"STATEMENT WILL BE FLUSHED"&CRLF);
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
BOOLEAN PROCEDURE MODIFY_CONTINUE(INTEGER ERR_NO; STRING MESS);
α ERROR(ERR_NO,MESS);
return(false);
β;
BOOLEAN PROCEDURE MODIFY_FLUSH(INTEGER PP,ERR_NO; STRING MESS);
α F_STATE(PP,ERR_NO,MESS);
return(false);
β;
REQUIRE "[][]" DELIMITERS;
! begin_P,end_P, open_paren_P;
recursive procedure begin_P;
α INTEGER SAVE_DEC_NUM,SAVE_MACRO_DEC_NUM,SAVE_DIMEN_DEC_NUM;
INTEGER SAVE_ARRAY_DEC_NUM,SAVE_PROCEDURE_DEC_NUM;
record_pointer(any_class) rr;
STRING B1,B2,E1,E2,TT; STRING S, BLK_NAME, BLK_NAME_END;
STRING UNUSED_S;
IFC DEFIN_PRINT_SWITCH THENC STRING UNDEFINED_S;ENDC
TT←"("&LABL;
B1←B2←"BEGIN";
E1←E2←"END";
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
SAVE_ARRAY_DEC_NUM←ARRAY_DEC_NUM; ARRAY_DEC_NUM←0;
SAVE_PROCEDURE_DEC_NUM←PROCEDURE_DEC_NUM; PROCEDURE_DEC_NUM←0;
SAVE_MACRO_DEC_NUM←MACRO_DEC_NUM; MACRO_DEC_NUM←0;
SAVE_DIMEN_DEC_NUM←DIMEN_DEC_NUM; DIMEN_DEC_NUM←0;
IF EQU(TOKEN,"BEGIN") THEN
α B2←"CO"&B2;E2←"CO"&E2;TT←TT&"$BL";β
ELSE α B1←"CO"&B1;E1←"CO"&E1;TT←TT&"$CO";β;
PRINT(TT);
printout;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN α BLK_NAME←TOKEN; printout β
ELSE α BLK_NAME←NULL; REJECT←TRUE; β;
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,E1) DO
α
P_STATEMENT;
if reject=false then GET_TOKEN ELSE REJECT←false;
IF TYPE_OF_RES_WORD≠end_RES
THEN ERROR_REJECT(4,
"Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,E2) THEN
α
ERROR(5,"Block ends with " & E2 & cr
& "Continue will view as "& E1);
TOKEN←E1;
β;
PRINTOUT;
β;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN BLK_NAME_END←TOKEN
ELSE α BLK_NAME_END←NULL; REJECT←TRUE;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
if token=";" then out(channew,";");
endc
β;
IF ¬(EQU(BLK_NAME,BLK_NAME_END) OR EQU(BLK_NAME_END,NULL))
THEN ERROR(600, "Block name at end does not agree with that at beginning.");
UNUSED_S←NULL;
IFC DEFIN_PRINT_SWITCH THENC UNDEFINED_S←NULL; ENDC;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α STRING SS;
SYMBOL_TABLE[HASH(SS←ID_LIST:NAME[TOP_ID],id_hasher)]
← ID_LIST:NEXT[TOP_ID];
IF ¬USED(TOP_ID) THEN UNUSED_S←UNUSED_S&CRLF& "⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
IFC DEFIN_PRINT_SWITCH THENC
IF ¬DEFINED(TOP_ID) THEN UNDEFINED_S←UNDEFINED_S&CRLF&"⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
ENDC
TOP_ID←ID_LIST:LAST[RR←TOP_ID];
β;
IF LENGTH(UNUSED_S)≠0 THEN UNUSED_S←UNUSED_S&
CRLF & " WERE NEVER USED";
IFC DEFIN_PRINT_SWITCH THENC
IF LENGTH(UNDEFINED_S)≠0 THEN UNUSED_S←UNUSED_S&CRLF & UNDEFINED_S &
CRLF & " WERE NEVER DEFINED";
ENDC
IF LENGTH(UNUSED_S)≠0 THEN ERROR(-1,UNUSED_S);
FOR I←1 STEP 1 UNTIL MACRO_DEC_NUM DO
α
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_MACRO],macro_hasher)]
←MACRO_LIST:NEXT[TOP_MACRO];
TOP_MACRO←MACRO_LIST:LAST[RR←TOP_MACRO];
β;
FOR I←1 STEP 1 UNTIL DIMEN_DEC_NUM DO
α
DIMENS_TABLE[HASH(DIMENS_EXPONENT:NAME[TOP_DIMENS],metric_hasher)]
←DIMENS_EXPONENT:NEXT[TOP_DIMENS];
TOP_DIMENS←DIMENS_EXPONENT:LAST[rr←TOP_DIMENS];
β;
FOR I←1 STEP 1 UNTIL ARRAY_DEC_NUM DO
α
ARRAY_SYMBOL_TABLE[HASH(ARRAY_LIST:NAME[TOP_ARRAY],array_hasher)]
←array_list:NEXT[TOP_array];
TOP_array←array_list:LAST[rr←TOP_array];
β;
FOR I←1 STEP 1 UNTIL procedure_DEC_NUM DO
α
procedure_SYMBOL_TABLE[HASH(procedure_LIST:NAME[TOP_procedure],procedure_hasher)]
←procedure_list:NEXT[TOP_procedure];
TOP_procedure←procedure_list:LAST[rr←TOP_procedure];
β;
DEC_NUM←SAVE_DEC_NUM;
MACRO_DEC_NUM←SAVE_MACRO_DEC_NUM;
ARRAY_DEC_NUM←SAVE_ARRAY_DEC_NUM;
PROCEDURE_DEC_NUM←SAVE_PROCEDURE_DEC_NUM;
DIMEN_DEC_NUM←SAVE_DIMEN_DEC_NUM;
PRINT(")");
PRINTOUT;
β;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
IF TOKEN=";" THEN print("()");
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
PRINTOUT;
β;
! if_P, plan_P, while_P;
procedure if_P;
α ! IF STATEMENT FOUND;
IF PLAN_STATEMENT THEN PRINT("("&LABL&"$CIF") ELSE PRINT("("&LABL&"$IF");
PLAN_STATEMENT←FALSE;
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(1,10,"Conditional for IF must be boolean");
GET_TOKEN;
IF ¬EQU(TOKEN,"THEN") THEN
ERROR_REJECT(9,"Missing THEN. Continue will insert it.");
P_STATEMENT;
GET_TOKEN;
IF EQU(TOKEN,"ELSE") THEN P_STATEMENT ELSE REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
procedure plan_P;
α ! PLAN STATEMENT FOUND;
GET_TOKEN;
IF ¬(EQU(TOKEN,"IF") OR EQU(TOKEN,"WRITE") OR EQU(TOKEN,"ERROR")
OR EQU(TOKEN,"FOREACH")) THEN MODIFY_FLUSH(0,11,"Illegal token to "&
"follow PLAN: "&TOKEN);
REJECT←TRUE;
PLAN_STATEMENT←TRUE;
P_STATEMENT;
PLAN_STATEMENT←FALSE;
β;
procedure while_P;
α ! WHILE STATEMENT FOUND;
PRINT("("&LABL&"$WH");
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,11,"Conditional for WHILE must be boolean or sclar.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(12,"Missing DO. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! for_P,case_P,do_P;
procedure for_P;
α RPTR(ID_LIST) POINT;RPTR(DIMENS_EXPONENT)POINTD; ! FOR STATEMENT FOUND;
! ERROR_BUFFER←CURLINER;
GET_TOKEN;
IF TYPE_OF_TOKEN=undeclared_token
THEN
α MODIFY_CONTINUE(0,"Undeclared variable "&TOKEN&" declared a scalar");
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←scalar_VALUE;
ID_LIST:DIMEN[POINT]←NIL_DIMENS;
PRINT("($SVAR "&TOKEN&")");
β
ELSE
α POINT←TOKEN_PTR;
IF TYPE_OF_TOKEN≠id_token OR ID_TYPE≠scalar_value
THEN MODIFY_CONTINUE(1300, "Need scalar ID here.");
β;
PRINT("("&LABL&"$FO "&ID_LIST:NAME[POINT]);
POINTD←ID_LIST:DIMEN[POINT];
USE(POINT); DEFIN(POINT);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"←") THEN
ERROR_REJECT(14,"Need left arrow here for FOR statement.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"STEP") THEN
ERROR_REJECT(16,"Need STEP here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"UNTIL") THEN
ERROR_REJECT(17,"Need UNTIL here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(18,"Need DO here.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
recursive procedure case_P;
α PRINT("("&LABL&"$CASE");
spacing←spacing+1;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(SCALAR_VALUE,NIL_DIMENS,
"index part of case statement")
THEN ERROR(19, "Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN, "OF") THEN ERROR_REJECT(20, "Need OF here in CASE statement");
get_token;
IF ¬EQU(TOKEN, "BEGIN") THEN ERROR_REJECT(21, "Need BEGIN here in CASE statement.");
GET_TOKEN; REJECT←TRUE;
IF EQU(TOKEN, "[") OR EQU(TOKEN,"ELSE") THEN
α BOOLEAN ELSE_SEEN; ELSE_SEEN←FALSE;
DO α GET_TOKEN;
IF EQU(TOKEN,"ELSE")
THEN IF ELSE_SEEN THEN ERROR(20, "ELSE seen twice in this CASE statement")
ELSE α ELSE_SEEN←TRUE; PRINT (" -1"); β
ELSE IF EQU(TOKEN,"[")
THEN α GET_TOKEN;
IF TYPE_OF_TOKEN≠numeric_token then
ERROR(21,"require an integer number here for numbered case statement");
PRINT(TOKEN);
GET_TOKEN;
IF ¬EQU(TOKEN,"]") THEN ERROR(22,"Need ] here for numbered case statement");
β
ELSE ERROR(24,"Need [ or ELSE here in CASE statement");
GET_TOKEN; REJECT←TRUE;
IF ¬EQU(TOKEN,"[") AND ¬EQU(TOKEN,"ELSE")
THEN α P_STATEMENT;
GET_TOKEN;
IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END")
THEN ERROR(23,"Need ; or END between statements in a CASE statement");
β;
β UNTIL EQU(TOKEN,"END");
β
ELSE DO α P_STATEMENT; GET_TOKEN;
IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END")
THEN ERROR(24,"need ; between statements in CASE statement");
β UNTIL EQU(TOKEN,"END");
spacing←spacing - 1;
print(")");
β;
procedure do_P;
α print("("&labl&" $UNTL");
SPACING←SPACING+1;
P_statement;
Get_token;
if not equ(token,"UNTIL") then error_reject(35, "need UNTIL here for DO statement, continue will insert");
printout;
p_exp;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,0,"NEED A BOOLEAN EXPRESSION IN DO...UNTIL STATEMENT");
SPACING←SPACING-1;
print(")");
printout;
β;
! move_P,affix_P,unfix_P;
procedure move_P;
α RPTR(ID_PROP)IDX; IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here.");
IF EQU(CURRENT_FRAME←ID_PROP:STOKEN[IDX],"BPARK") OR EQU(CURRENT_FRAME,"YPARK")
THEN MODIFY_FLUSH(0,19,"You can't move "&CURRENT_FRAME&" !!!!");
PRINT("("&LABL&"$MO "&CURRENT_FRAME);
SPACING←SPACING+1;
IF ¬CHECK_NEXT_TOKEN(19,NULL,"TO") THEN REJECT←TRUE;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(trans_VALUE,DISTANCE_DIMENS, "FRAME Expression")
THEN ERROR_REJECT(20,"Need either a FRAME or TRANSFORM expression here.");
! PRINTOUT;
P_CLAUSES;
CURRENT_FRAME←null;
SPACING←SPACING-1;
PRINT(")");
β;
procedure affix_p;
α RPTR(ID_PROP) IDX1,IDX2,IDXB,IDXA;
STRING TRANS; RPTR(ID_LIST,ARRAY_LIST) POINT;
BOOLEAN BY_FLAG, AT_FLAG, RIGID_FLAG;
STRING BY_S,AT_S,RIGID_S;
IF (IDX1←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IDX1]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here for affixment.")
ELSE POINT←ID_PROP:TPTR[IDX1];
DEFIN(POINT,ID_PROP:TYPE[IDX1]); AFFIX(POINT,ID_PROP:TYPE[IDX1]);
CURRENT_FRAME←ID_PROP:STOKEN[IDX1];
IF ¬CHECK_NEXT_TOKEN(21,NULL,"TO") THEN REJECT←TRUE;
IF (IDX2←GET_ID)=NULL_RECORD or ID_PROP:ID_CLASS[IDX2]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,12,"Need frame ID here for affixment.")
ELSE POINT←ID_PROP:TPTR[IDX2];
! IF ¬DEFINED(POINT) THEN UNDEFINED_VAR; ! COMMENTED OUT FOR ARG;
AFFIX(POINT,ID_PROP:TYPE[IDX2]);
GET_TOKEN;
BY_FLAG←AT_FLAG←RIGID_FLAG←FALSE;
AT_S←RIGID_S←NULL;
WHILE ¬(BY_FLAG AND AT_FLAG AND RIGID_FLAG)
DO α INTEGER J; STRING S; J←1;
FOR S← "BY","AT","RIGIDLY","NONRIGIDLY"
DO IF EQU(TOKEN,S) THEN DONE ELSE J←J+1;
CASE J OF
α
[1] α IF BY_FLAG THEN ERROR(100,"double BY variable")
ELSE by_flag←true;
IF (IDXB←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IDXB]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,24,"Need trans ID here for BY in affix statement.");
IF block_level_of_defn=0
THEN MODIFY_FLUSH(0,25,"You are using predeclared variable in BY part of affixment");
! IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
BY_S←ID_PROP:STOKEN[IDXB];
GET_TOKEN;
β;
[2] α IF AT_FLAG THEN ERROR(19,"Double AT variable")
ELSE AT_FLAG←TRUE;
P_EXP2; AT_S←OUTEXPR; GET_TOKEN;
β;
[3] [4]
α IF RIGID_FLAG THEN ERROR(21,"Can only specify rigid or nonrigid affixment once")
else rigid_flag←true;
RIGID_S←TOKEN; GET_TOKEN;
β;
[5] α IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END") AND ¬EQU(TOKEN,"COEND")
THEN ERROR(22,"Cant use ⊂"&token&"⊃ in this affixment statement");
IF ¬AT_FLAG THEN α AT_FLAG←TRUE; AT_S←"()"; β;
IF ¬BY_FLAG THEN α BY_FLAG←TRUE; by_S←"()";β;
IF ¬RIGID_FLAG THEN α RIGID_FLAG←TRUE; RIGID_S←"RIGIDLY"; β;
β
β;
β;
REJECT←TRUE;
PRINT("("&LABL&"$AFFIX "&ID_PROP:STOKEN[IDX1]&" "&ID_PROP:STOKEN[IDX2]
&" "&BY_S&" "); SPACING←SPACING + 1;
PRINT(AT_S&" "&RIGID_S&")"); SPACING←SPACING-1;
CURRENT_FRAME←NULL;
β;
procedure unfix_P;
α RPTR(ID_LIST,ARRAY_LIST) POINT; ! UNAFFIX STATEMENT FOUND;
RPTR(ID_PROP) IDX1,IDX2;
IDX1←GET_ID;
IF IDX1=NULL_RECORD OR ID_PROP:ID_CLASS[IDX1]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here in unfix statement.");
POINT←ID_PROP:TPTR[IDX1];
IF ¬DEFINED(POINT,ID_PROP:TYPE[IDX1]) THEN UNDEFINED_VAR;
IF ¬AFFIXED(POINT,ID_PROP:TYPE[IDX1]) THEN UNAFFIXED_VAR;
CURRENT_FRAME←ID_PROP:STOKEN[IDX1];
IF ¬CHECK_NEXT_TOKEN(20,NULL,"FROM") THEN REJECT←TRUE;
IDX2←GET_ID;
IF IDX2=NULL_RECORD OR ID_PROP:ID_CLASS[IDX2]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,15,"Need frame ID here in unfix statement.");
IF ¬DEFINED(POINT,ID_PROP:TYPE[IDX2]) THEN UNDEFINED_VAR;
PRINT("("&LABL&"$UNFIX"&" "&ID_PROP:STOKEN[IDX1]&" "&
ID_PROP:STOKEN[IDX2]&")"); CURRENT_FRAME←null;
β;
! signal_p, wait_p;
procedure signal_wait_P(string ws);
α
RPTR(ID_PROP)IDX;
IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠EVENT_VALUE
THEN MODIFY_FLUSH(0,19,"Need event ID here in a SIGNAL or WAIT statement.");
PRINT("("&LABL&"$EV "&ID_PROP:STOKEN[IDX]&" "&WS&")");
DEFIN(ID_PROP:TPTR[IDX],ID_PROP:TYPE[IDX]);
β;
procedure signal_P;
signal_wait_P(" +"); ! SIGNAL STATEMENT FOUND;
procedure wait_P;
signal_wait_P(" -"); ! WAIT STATEMENT FOUND;
! when_P;
IFC FALSE THENC
procedure when_P;
α RPTR (ID_LIST) POINT; STRING VAR, ALSO_OP, CHG_LAB;
BOOLEAN TEMP; LABEL RE_TRY;
! WHEN STATEMENT FOUND;
GET_TOKEN;
RE_TRY:
IF ¬EQU(TOKEN,"CHANGING") THEN
ERROR_REJECT(30,"Need word CHANGING here for a WHEN CHANGING statement."&
" Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN=undeclared_token THEN MODIFY_CONTINUE(31,"Undefined ID");
VAR←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"ALSO")
THEN ALSO_OP←"ALSO_DO"
ELSE IF EQU(TOKEN,"DON'T")
THEN ALSO_OP←"ALSO_DON'T"
ELSE IF EQU(TOKEN,"ONLY")
THEN ALSO_OP←"ALSO_ONLY"
ELSE MODIFY_CONTINUE(32,"Illegal ALSO_OP");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(33,"Need DO here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN TEMP←TRUE
ELSE IF ID_TYPE=ch_label_VALUE
THEN TEMP←FALSE
! ?????; ELSE IF ID_TYPE>world_VALUE
THEN
α ERROR(34,"Can only handle CH_LABEL here. Continue while delete this label.");
TEMP←TRUE;
β
ELSE TEMP←TRUE;
IF TEMP
THEN
α CHG_LAB←T_GEN; PRINT("($CHGLAB "&CHG_LAB&")"); REJECT←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE
α CHG_LAB←TOKEN; GET_TOKEN;
IF EQU(TOKEN,":")
THEN α TEMP←TRUE; CHANGER_HEAD←CHG_LAB&" CHG "; β
ELSE α REJECT←TRUE; PRINT("($"&ALSO_OP&" "&VAR&" "&CHG_LAB&")"); β;
β;
IF TEMP
THEN
α PRINT("($"&ALSO_OP&" "&VAR); SPACING←SPACING+1; P_STATEMENT;
SPACING←SPACING-1; PRINT(")");
β;
β;
ENDC
! dump_P;
procedure dump_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING;
! DUMP STATEMENT FOUND;
IDSTRING←null; GET_TOKEN;
IF ID_TYPE=world_VALUE
THEN PRINT("("&LABL&"$DBD "&TOKEN&")")
ELSE
α
DO α
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>event_VALUE THEN ERROR(35,"Undefined ID.");
IDSTRING←IDSTRING&" "&TOKEN;GET_TOKEN;
IF ¬EQU(TOKEN,"IN") and TOKEN≠";"
THEN
α IF TOKEN≠","
THEN ERROR_REJECT(36, "Need comma or IN or ; here. Continue will insert it.");
GET_TOKEN;
β;
β
UNTIL EQU(TOKEN,"IN") OR EQU(TOKEN,";");
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE
THEN ERROR(37,"Need a world ID here.")
ELSE IDSTRING←IDSTRING & " " & TOKEN;
β else reject←true;
PRINT ("("&LABL&"$PVL "&IDSTRING&")");
β;
β;
! assert_P;
IFC false thenc
procedure assert_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING,COM;INTEGER VAR_TYPE;
! ASSERT OR DENY STATEMENT FOUND;
COM←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"FORM")
THEN
α IDSTRING←null; GET_TOKEN;
IF ¬EQU(TOKEN,"(")
THEN ERROR_REJECT(37,"Need left paren here. Continue will insert it.");
WHILE ¬EQU(TOKEN,")")
DO α
GET_TOKEN; IDSTRING←IDSTRING&TOKEN&" "; GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",")
THEN ERROR_REJECT(38,"Need either comma or right paren here."&
" Continue will insert a comma.");
β;
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT("("&LABL&COM&" ($SF "&IDSTRING&") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("("&LABL&COM&" ($SF "&IDSTRING&"))"); β;
β
ELSE
α STRING VAR;
! ?????; IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>trans_VALUE
THEN
α ERROR(40,"Need variable ID here.");
POINT←SYMBOL_TABLE[HASH("GARB_ID",id_hasher)];
β
ELSE POINT←TOKEN_PTR;
VAR_TYPE←ID_TYPE;GET_TOKEN;
IF ¬EQU(TOKEN,"=")
THEN ERROR(41,"Sorry, can only handle equality right now.");
PRINT("("&LABL&COM&" ($AF "&VAR&" = "); SPACING←SPACING+1;
P_EXP; SPACING←SPACING-1;
IF VAR_TYPE≠EXP_TYPE THEN ERROR(42,"Types don't match on equality test.");
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT(") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("))"); β;
β;
β;
endc
! on_P, reference_P,deproach_P;
procedure on_P;
α RPTR (ID_LIST) POINT;
! CONDITION MONITER FOUND;
BOOLEAN ICMT;
ICMT←INSIDE_CONDITION_MONITOR;
ifc false thenc IF ¬EQU(LABL,null)
THEN
IF LABEL_TYPE≠cm_label_VALUE
THEN
α
ERROR(43,"Must have condition monitor label if any label is uesed. Continue will flush label.");
LABL←null;
β; endc
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN P_CONDITION(0,"( "&LABL&"$ON +")
ELSE α CHECK_NEXT_TOKEN(27,null,"ON"); P_CONDITION(0,"("&LABL&"$ON -"); β;
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO in condition monitor statement. Continue will insert it.");
P_STATEMENT;
INSIDE_CONDITION_MONITOR←ICMT;
SPACING←SPACING-1;
PRINT(")");
β;
IFC FALSE THENC
procedure reference_P;
α RPTR (ID_LIST) POINT; ! NEW WORLD DEF;
GET_TOKEN;
IF ¬EQU(TOKEN,"POINT") THEN
ERROR_REJECT(46,"Need POINT here for a REFERENCE POINT statement.");
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(47,"Need a world variable here.");
PRINT("("&LABL&"$NW "&TOKEN&")");
β;
ENDC
procedure deproach_P;
α
RPTR(ID_PROP) IDX;
string ss; ss←"("&labl&" $DEPROACH ";
get_token;
IF ¬EQU(TOKEN,"(") THEN ERROR_reject (47, "need left paren after deproach");
IF (IDX←GET_ID)=NULL_RECORD OR (ID_PROP:ID_CLASS[IDX] ≠ TRANS_VALUE)
THEN
error(47, "only frames can have deproaches");
SS←SS&id_prop:stoken[idx];
get_token;
IF TOKEN≠")" THEN ERROR(48, "need right paren here in deproach statement");
get_token;
IF TOKEN≠"←" THEN ERROR(49, "need ← here in deproach statement");
p_exp2;
SS←SS&" "&OUTEXPR&")"; PRINT(SS);
β;
! open_P,center_P,stop_P,enable_P,disable_P;
procedure open_P;
α STRING HAND; ! OPEN/CLOSE FOUND;
RPTR (ID_LIST) POINT;
check_next_token(48,"Unknown hand in OPEN/CLOSE statement",
"BHAND","YHAND"); HAND←TOKEN;
check_next_token(49,NULL,"TO");
PRINT("("&LABL&"$MO "&HAND);
SPACING←SPACING+1;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DISTANCE_DIMENS,
"OPEN/CLOSE statement")
THEN ERROR(121,"Need scalar quantity here in an OPEN or CLOSE statement");
GET_TOKEN;
IF ¬EQU(TOKEN,"WITH") THEN REJECT←TRUE
ELSE α GET_TOKEN;
IF EQU(TOKEN,"NO_NULLING") THEN PRINT("($NNULL +)")
ELSE IF EQU(TOKEN,"NULLING") THEN PRINT("($NNULL -)")
ELSE ERROR(122,"WITH CAN ONLY TAKE NULLING OR NO_NULLING HERE");
β;
SPACING←SPACING-1;
PRINT(")");
β;
procedure center_P;
IF check_next_token(50,"Unknown arm in CENTER statement",
"BARM","YARM") then PRINT("("&LABL&"$CENTER "&TOKEN&")");
procedure stop_P;
α ! STOP FOUND;
RPTR(ID_LIST) R1;
GET_TOKEN;
IF (R1←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α IF (ID_LIST:TYPE[R1]≠TRANS_VALUE)
THEN ERROR(49, "Trying to stop a non-frame");
PRINT("("&LABL&"$STOP "&TOKEN&")");
β
ELSE α IF TYPE_OF_TOKEN = undeclared_token
THEN PRINT("("&LABL&" $STOP "&TOKEN&")")
ELSE α REJECT←TRUE; PRINT("("&LABL&"$STOP )");β;
β;
β;
procedure denable_P(STRING en);
α ! ENABLE/DISABLE found;
STRING S1;
s1← "(" & LABL & " $CMABLE " & en;
GET_TOKEN;
IF ID_TYPE = LABEL_VALUE
THEN α S1← S1&TOKEN&" )"; USE(TOKEN_PTR); β
ELSE α REJECT←TRUE; IF INSIDE_CONDITION_MONITOR
THEN S1 ← S1 & " )"
ELSE ERROR(123, "Only label can be used in ENABLE or DISABLE statement.");
β;
PRINT(S1);
β;
procedure enable_P;
denable_P(" + ");
procedure disable_P;
denable_P(" - ");
! require_P;
procedure require_P;
α ! REQUIRE STATEMENT FOUND;
LABEL RE_TRY;
GET_TOKEN;
RE_TRY:
IF ¬(require_beg ≤ TYPE_OF_RES_WORD ≤ require_end)
THEN α IF MODIFY_FLUSH(0,51,"Illegal token after REQUIRE") THEN GOTO RE_TRY; β
ELSE
CASE TYPE_OF_RES_WORD - require_beg OF
α
[source_file_X] α
integer res_word_sav; string new_file,sav_token;
GET_TOKEN;
new_file←token;
GET_TOKEN;
sav_token←token; res_word_sav←type_of_res_word;
TOP_SOURCE←PUSH_SOURCE_LIST(TOP_SOURCE);
SOURCE_LIST:NUM[TOP_SOURCE]←0;
WHILE ¬ got_input(PRESENT_file←open_new_file(new_file))
DO α ERROR(55,"FILE NOT AVAILABLE");
new_file←infile; β;
CHANIN←file:chn[PRESENT_FILE];
if equ(file:device[PRESENT_file],"TTY")
then
α
CHECK_WANT_COPY;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
β;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
open_NEW_AL_FILE(PRESENT_FILE, "NEW");
endc
pagenum←linenum←0;
GET_TOKEN;
IF EQU(CURLINE[1 TO 17],"COMMENT ⊗ VALID")
THEN α GARB←READ(SEMICOLON_A_BREAK); get_token; β;
PARSED_STRING←null; curliner←curline;
token←sav_token;
type_of_res_word←res_word_sav;
reject←true;
switch_file←true;
β;
[message_x] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_FLUSH(0,52,"Need string after REQUIRE MESSAGE");
OUTSTR(TOKEN);
β;
[error_modes_x] α
INTEGER I,L; STRING S; BOOLEAN T;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_FLUSH(0,52,"Need string after REQUIRE ERROR_MODES");
L←length(token);
FOR I←1 STEP 1 UNTIL L DO
α S←TOKEN[I FOR 1];
IF EQU(S,"-") THEN α I←I+1;
S←TOKEN[I FOR 1];
T←FALSE;
β
ELSE T←TRUE;
CASE S OF
α
["L"] α COMPILE_LOGGING←T;
IF ¬T THEN LOGGING←T; β;
["A"] AUTO_PROCEED←T;
["F"] STRICT_DIMEN_CHECK←T;
["M"] PROMPT_FOR_MODIFIABLE_ERROR_ONLY←T;
["N"] WANT_DUP_FILE←FALSE;
ELSE ERROR(0,"Error_mode " & s & " undefined. Only modes LAFMN are applicable")
β;
β;
β;
[compiler_switches_x] α
INTEGER I,L,I1; STRING S; BOOLEAN NON_EXIST_SWITCH,BAIL_WANTED;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
L←LENGTH(TOKEN);
FOR I←1 STEP 1 UNTIL L DO
α
S←TOKEN[I FOR 1];
NON_EXIST_SWITCH←TRUE;
FOR I1←0 STEP 1 UNTIL SWITCH_MAX DO
IF EQU(S,SWITCH_NAME[I1]) THEN
α SWITCH_SETTING[I1]←TRUE;
IF I1=B_X THEN BAIL_WANTED←TRUE;
NON_EXIST_SWITCH←FALSE;
β;
IF NON_EXIST_SWITCH THEN
ERROR(0,"Switch " & S & " unknown");
β;
IF BAIL_WANTED
THEN α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
β;
[bail_X] α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
β;
β;
! dimension_P;
procedure dimension_P;
α "dimen_p"
! DIMENSION STATEMENT FOUND;
STRING DIMEN_NAME;
RPTR(DIMENS_EXPONENT) D1;
forward recursive rptr(dimens_exponent) procedure factor;
recursive rptr(dimens_exponent) procedure term;
α rptr(dimens_exponent) r1,R2;
R1←FACTOR;
IF R1=NULL_RECORD THEN ERROR(0000,"invalid expression.");
WHILE TOKEN="*" OR TOKEN="/" DO
α
STRING S; S←TOKEN;
GET_TOKEN;
R2←FACTOR;
IF S="*" THEN R1←MULTIPLY_DIMENSIONS(R1,R2)
ELSE R1←DIVIDE_DIMENSIONS(R1,R2);
β;
RETURN(R1);
β;
recursive rptr(dimens_exponent)procedure factor;
α rptr(dimens_exponent)r1,r2;
IF TOKEN="(" THEN
α R1←TERM; IF TOKEN≠")" THEN ERROR(0000,"unbalanced paren")
else get_token;
β
ELSE IF TOKEN = "INV" THEN
α GET_TOKEN; IF TOKEN≠"(" THEN ERROR(0000,"need open paren after INV, proceed will insert")
ELSE R2←TERM;
R1←DIVIDE_DIMENSIONS(NIL_DIMENS,R2);
β
ELSE α
r1←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE);
IF r1=NULL_RECORD THEN ERROR(0000, TOKEN & "not declared.")
ELSE GET_TOKEN;
β;
RETURN(R1);
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token AND BLOCK_LEVEL_OF_DEFN=BLOCK_LEVEL
THEN MODIFY_FLUSH(0,61,"Can only use unreserved ID's for dimensions.");
DIMEN_NAME←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(62,"Need = in DIMENSION statement.");
GET_TOKEN;
D1←TERM;
IF TOKEN≠";" THEN ERROR(0000,"NEED SEMICOLON HERE");
IF D1=NULL OR D1=NIL_DIMENS THEN
insert_entry(DIMEN_NAME,DIMENSION_TYPE_TABLE)
ELSE INSERT_ENTRY(DIMEN_NAME,DIMENSION_TYPE_TABLE,D1);
REJECT←TRUE;
β "dimen_p";
! string_P;
ifc false thenc
procedure string_P;
α
BOOLEAN NEW;RPTR(ID_LIST)R1; LABEL RE_TRY;
INSIDE_STRING_DECLARATION←TRUE;
IF EQU(TOKEN,"NEW_STRING") THEN NEW←TRUE ELSE NEW←FALSE;
GET_TOKEN;
RE_TRY:
R1←TOKEN_PTR;
IF NEW
THEN α IF R1=NULL_RECORD OR ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]≠BLOCK_LEVEL
THEN r1←insert_entry(token,id_type_table)
ELSE MODIFY_CONTINUE(12,TOKEN &" already defined");
β
ELSE IF R1=NULL_RECORD
THEN α ERROR( 13, TOKEN &" not defined, will define"); R1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE) β;
get_token;
if token≠"=" THEN ERROR_REJECT(15,"Need ""="" here, continue will insert it");
INSIDE_STRING_DECLARATION←FALSE;
id_list:body[r1]←string_expr;
id_list:type[r1]←string_value;
β;
endc
! abort_P, note_P,comment_P,speed_factor_P,wrist_P,setbase_P;
procedure abort_P;
α ! PRINT/ABORT/PAUSE STATEMENT FOUND;
IF EQU(TOKEN,"PAUSE") THEN
α
p_exp2;
IF EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,1102,"Need a scalar expression here for a PAUSE statement.");
PRINT("( $PAUSE "&OUTEXPR&")");
β
ELSE α
PRINT("( $"&TOKEN&" ");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1104,"Need left paren here, continue will insert it.");
TOKEN←",";
WHILE EQU(TOKEN,",") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN=string_token THEN PRINT(dquote&TOKEN&dquote)
ELSE α
REJECT←TRUE;
P_EXP;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(1103,"Illegal separator. Continue"&
" will try to insert reasonable separator.");
β;
IF ¬EQU(TOKEN,")") THEN
ERROR(1104,"Need right paren here, continue will insert it.");
SPACING←SPACING-1;
PRINT(")");
β;
β;
procedure note_P;
α
BOOLEAN LPAR; STRING T,T2;
LPAR←FALSE;
T←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN α LPAR←TRUE; GET_TOKEN β;
IF TYPE_OF_TOKEN≠string_token then F_STATE(0,1102,
"Need string expression here for "& token & " statement.")
ELSE
α T2←TOKEN;
IF LPAR THEN α GET_TOKEN; IF ¬EQU(TOKEN,")") THEN ERROR(1234,
"Parenthesis mismatch.") β;
PRINT("( $"& T & space & dquote & T2 & dquote & " )");
β;
β;
procedure comment_P;
GARB←READ(semicolon_A_break);
procedure speed_factor_P;
α
GET_TOKEN;
IF ¬TOKEN_EQU("←") THEN ERROR_REJECT(37, "Need ← here");
p_exp2;
IF EXP_TYPE≠SCALAR_VALUE THEN ERROR(36, "Need to have scalar expression for SPEED_FACTOR");
PRINT("($SPEED_FACTOR "&OUTEXPR& " )");
β;
procedure SETBASE_P;
PRINT("("&LABL&"$SETBASE)");
procedure WRIST_P;
α
GET_TOKEN;
IF ¬TOKEN_EQU("(") THEN ERROR_REJECT(37,"Need ( here");
GET_TOKEN;
IF TYPE_OF_TOKEN=ARRAY_TOKEN AND ARRAY_TYPE=SCALAR_VALUE
THEN BEGIN
PRINT("("&LABL&" $WRIST "&TOKEN&")");
GET_TOKEN;
IF ¬TOKEN_EQU(")")THEN ERROR_REJECT(37,"Need ) here");
end
else error(45,"Need scalar array as argument of WRIST");
β;
! define_P,declare_P,global_P,procedure_P,return_P;
procedure define_P;
if ¬macro_handler then goto FLUSH;
rclass tstack(rptr(id_list,array_list)ptr; integer isid; rptr(tstack)next);
rptr(tstack) tstacktop,tstacktemp;
procedure pushtstack(rptr(id_list,array_list)rr; integer isid);
α tstacktemp←new_record(tstack);
tstack:ptr[tstacktemp]←rr;tstack:isid[tstacktemp]←isid;
tstack:next[tstacktemp]←tstacktop;
tstacktop←tstacktemp;
β;
boolean procedure findintstack(string tt);
α rptr(tstack)temp;
temp←tstacktop;
while temp≠null_record do
α if tstack:isid[temp] then
α if equ(tt,id_list:name[tstack:ptr[temp]]) then return(true); β
else if equ(tt,array_list:name[tstack:ptr[temp]]) then return(true);
temp←tstack:next[temp];
β;
return(false);
β;
recursive procedure declare2_P(reference string dec_string; reference integer how_many;
rptr(dimens_exponent)dim_ptr; integer type1,blklvl);
α integer type2; boolean save_inside_declar_p;
save_inside_declar_p←inside_declare_p;
inside_declare_P←true;
if type1=frame_value then type2←trans_value else type2←type1;
if equ(token,"ARRAY") then
α "array list"
string ss; rptr(array_list)aptr; integer i0,i1; i1←i0←0;
aptr←null_record; ss←"$ARAY "&dec_name[type1]&" ";
do α "look for valid id"
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3001,token&" is a reserved word and may not be used an an identifier name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=blklvl or findintstack(token)
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else
α "found suitable id" integer nfields; nfields←0;
ss←ss&token&" (";
array_list:name[aptr←new_record(array_list)]←token;
array_list:dimen[aptr]←dim_ptr;
array_list:type[aptr]←type2;
array_list:block_level_of_defn[aptr]←blklvl;
pushtstack(aptr,false);
get_token;
i0←0;
if token≠"[" then MODIFY_FLUSH(0,3001,"need [ for delimiting fields of array declaration");
do α
p_exp2;
check_exp_type_dimens(scalar_value,nil_dimens,
"limits of array identifier which should be an undimensioned scalar expression");
ss←ss&outexpr;
get_token;
if token≠":" then MODIFY_FLUSH(0,3002,"need : to separate the ranges of the array limits");
p_exp2;
check_exp_type_dimens(scalar_value,nil_dimens,
"limits of array identifier which should be an undimensioned scalar expression");
get_token; nfields←nfields+1;
ss←ss&" "&outexpr; i0←i0+1;
if token≠"]" and token≠"," then MODIFY_FLUSH(0,3003, "need , or ] here in array declaration");
β until token="]";
ss←ss&" )"; i1←i1+1;
array_list:#dimens[aptr]←i0;
β "found suitable id";
get_token;
if token≠";" and token≠"," and not equ(token,"END") and token≠")"
then MODIFY_FLUSH(0,3003,"need ; or , here");
β "look for valid id" until token≠",";
reject←true;
dec_string←ss; how_many←i1;
β "array list"
else α "identifier list"
string ss; rptr(id_list)iptr; integer i1; i1←0;
ss←dec_name[type1]&" ";
reject←true;
do α "look for valid id"
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3001,token&" is a reserved word and may not be used an an identifier name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=blklvl or findintstack(token)
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else ss←ss&token&" ";
id_list:name[iptr←new_record(id_list)]←token;
id_list:dimen[iptr]←dim_ptr;
id_list:type[iptr]←type2;
id_list:block_level_of_defn[iptr]←blklvl;
pushtstack(iptr,true);
get_token;
if token≠";" and token≠"," and not equ(token,"END") and not equ(token,")")
then MODIFY_FLUSH(0,3003,"need ; or , here");
i1←i1+1;
β "look for valid id" until token≠",";
reject←true;
dec_string←ss; how_many←i1;
β "identifier list";
inside_declare_p←save_inside_declar_p;
β;
PROCEDURE PROCEDURE2_P(STRING DEC_STRING; RPTR(DIMENS_EXPONENT) DIM; INTEGER TYPE1);
α "procedure2_P"
rptr(dimens_exponent) dim2;string procname;
rptr(procedure_list)pptr;
integer type2;string ss,sss;integer totnarg;
INTEGER SAVE_DEC_NUM,SAVE_MACRO_DEC_NUM,SAVE_DIMEN_DEC_NUM,
SAVE_ARRAY_DEC_NUM,SAVE_PROCEDURE_DEC_NUM;
record_pointer(any_class) rr;
INTEGER I;
SAVE_DEC_NUM←DEC_NUM;DEC_NUM←0;
SAVE_ARRAY_DEC_NUM←ARRAY_DEC_NUM;ARRAY_DEC_NUM←0;
SAVE_PROCEDURE_DEC_NUM←PROCEDURE_DEC_NUM; PROCEDURE_DEC_NUM←0;
SAVE_MACRO_DEC_NUM←MACRO_DEC_NUM;MACRO_DEC_NUM←0;
SAVE_DIMEN_DEC_NUM←DIMEN_DEC_NUM;DIMEN_DEC_NUM←0;
if type1=frame_value then type2←trans_value else type2←type1;
if type1=0 then ss← "$PROC " else ss← "$PROC "&dec_name[type1];
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3004,TOKEN&" is reserved and may not be used as procedure name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=block_level
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else ss←ss&" "&token&" "; print(ss); ss←null;
procname←token;
get_token;
totnarg←0; tstacktop←null_record;
if token="("
then
α "procedure with arguments"
do
α "arguments in procedure"
integer narg, nn; string ssstoken;
get_token; ss←ss&"(";
if equ(token,"VALUE") or equ(token,"REFERENCE") then
α SS ← ss&" $"&token[1 to 3]&" "; get_token; β;
if type_of_token=metric_token then
α dim2←token_ptr; get_token; β;
if type_of_res_word=declare_res then
α nn←special_info;ssstoken←token; get_token; β else
MODIFY_FLUSH(0,3006,"need a type declaration here");
if nn≠vector_value and nn≠scalar_value and
nn≠trans_value and dim2≠null_record
then MODIFY_FLUSH(0,3000,ssstoken & " cannot take arbitrary dimensions");
if dim2=null_record then
case nn of
α
[scalar_value]
[plane_value]
[vector_value] DIM2←NIL_DIMENS;
[rot_value] DIM2←ANGLE_DIMENS;
[trans_value] DIM2←DISTANCE_DIMENS;
[frame_value] DIM2←DISTANCE_DIMENS;
ELSE DIM2←NULL_RECORD
β;
declare2_P(sss,narg,dim2,nn,block_level+1);
totnarg←totnarg + narg;
ss←ss&sss&")";
get_token;
if token≠";" and token≠")" then MODIFY_FLUSH(0,3007,
"need ; or ) to end argument list for procedure arguments");
β "arguments in procedure" until token=")";
β "procedure with arguments"
else α reject←true; β;
dec_string←ss;
get_token; if token≠";" then MODIFY_FLUSH(0,3008,"need ; at end of procedure declaration");
pptr←new_record(procedure_list);
if totnarg>0 then
α integer array isid,argmode[1:totnarg]; integer i;
rptr (id_list,array_list) array args[1:totnarg];
procedure_list:#args[pptr]←totnarg;
for i←totnarg step -1 until 1 do
α rptr(id_list,array_list)aiptr;
aiptr←tstack:ptr[tstacktop];
args[i]←aiptr;
if (isid[i]←tstack:isid[tstacktop]) then
insert_entry(id_list:name[aiptr],id_type_table,aiptr)
else insert_entry(array_list:name[aiptr],array_type_table,aiptr);
tstacktop←tstack:next[tstacktop];
β;
if tstacktop≠null_record then MODIFY_FLUSH(0,3009,"PARSER ERROR 3009 NON EMPTY STACK");
MEMORY[LOCATION(ARGS)]↔MEMORY[LOCATION(PROCEDURE_LIST:ARGS[PPTR])];
MEMORY[LOCATION(ISID)]↔MEMORY[LOCATION(PROCEDURE_LIST:ISID[PPTR])];
β;
insert_entry(procname,procedure_type_table,pptr);
procedure_list:type[pptr]←type2;
procedure_list:dimen[pptr]←dim;
print("("&ss&")"); printout;
p_statement;
printout;
print(")"); printout;
FOR I←1 STEP 1 UNTIL MACRO_DEC_NUM DO
α
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_MACRO],macro_hasher)]
←MACRO_LIST:NEXT[TOP_MACRO];
TOP_MACRO←MACRO_LIST:LAST[RR←TOP_MACRO];
β;
FOR I←1 STEP 1 UNTIL DIMEN_DEC_NUM DO
α
DIMENS_TABLE[HASH(DIMENS_EXPONENT:NAME[TOP_DIMENS],metric_hasher)]
←DIMENS_EXPONENT:NEXT[TOP_DIMENS];
TOP_DIMENS←DIMENS_EXPONENT:LAST[rr←TOP_DIMENS];
β;
FOR I←1 STEP 1 UNTIL ARRAY_DEC_NUM DO
α
ARRAY_SYMBOL_TABLE[HASH(ARRAY_LIST:NAME[TOP_ARRAY],array_hasher)]
←array_list:NEXT[TOP_array];
TOP_array←array_list:LAST[rr←TOP_array];
β;
FOR I←1 STEP 1 UNTIL procedure_DEC_NUM DO
α
procedure_SYMBOL_TABLE[HASH(procedure_LIST:NAME[TOP_procedure],procedure_hasher)]
←procedure_list:NEXT[TOP_procedure];
TOP_procedure←procedure_list:LAST[rr←TOP_procedure];
β;
DEC_NUM←SAVE_DEC_NUM;
MACRO_DEC_NUM←SAVE_MACRO_DEC_NUM;
ARRAY_DEC_NUM←SAVE_ARRAY_DEC_NUM;
PROCEDURE_DEC_NUM←SAVE_PROCEDURE_DEC_NUM;
DIMEN_DEC_NUM←SAVE_DIMEN_DEC_NUM;
insert_entry(procname,procedure_type_table,pptr);
β "procedure2_P";
procedure procedure_p;
α string ss; PRINT("("&LABL&" "); procedure2_p(ss,nil_dimens,0); β;
PROCEDURE DECLARE_P;
α integer type1; rptr(dimens_exponent)dim; string ss,sss; integer howmany;
string stemp;
dim←dim_ptr;
if (type1←special_info)≠vector_value and special_info≠scalar_value and
special_info≠trans_value and dim≠null_record
then MODIFY_FLUSH(0,3000,token & " cannot take arbitrary dimensions");
if dim=null_record then
case special_info of
α
[scalar_value]
[plane_value]
[vector_value] DIM←NIL_DIMENS;
[rot_value] DIM←ANGLE_DIMENS;
[trans_value] DIM←DISTANCE_DIMENS;
[frame_value] DIM←DISTANCE_DIMENS;
ELSE DIM←NULL_RECORD
β;
get_token;
stemp←"("&labl&" "; SS←Null;
if equ(token, "PROCEDURE")
then α print(stemp); procedure2_P(SS,dim,type1); β
else α integer i; rptr(id_list,array_list)iptr;
tstacktop←null_record;
DECLARE2_P(SS,HOWMANY,DIM,TYPE1,BLOCK_LEVEL);
print(stemp&ss&")");
FOR i←1 step 1 until howmany do
α iptr←tstack:ptr[tstacktop];
if tstack:isid[tstacktop] then insert_entry(id_list:name[iptr],id_type_table,iptr)
else insert_entry(array_list:name[iptr],array_type_table,iptr);
tstacktop←tstack:next[tstacktop];
β;
β;
β;
PROCEDURE RETURN_P;
α string s; s←labl;
get_token; reject←true;
if equ(token,";") or equ(token,"END") OR EQU(TOKEN,"ELSE")
THEN PRINT("("&S&" $RET )")
ELSE α p_exp2; print("("&s&" $RET "&outexpr&")"); β;
β;
! P_statement execution starts here;
INSIDE_STATEMENT←-100;
SAVSPACING←SPACING;
GET_TOKEN;
WHILE EQU(TOKEN,"COMMENT") DO
α GARB←READ(semicolon_A_break); GET_TOKEN; β;
GLOBAL_RE_TRY: SPACING←SAVSPACING;
LABL←CHANGER_HEAD; ! USUALLY NULL EXCEPT WHEN INSIDE A CHANGER.;
CHANGER_HEAD←null; LABEL_TYPE←0;
DIM_PTR←NULL_RECORD;
TRY_AGAIN:
CASE TYPE_OF_TOKEN OF
α
[numeric_token] MODIFY_FLUSH(0,1,"Statement can't begin with a scalar");
[string_token] MODIFY_FLUSH(0,2,"Statement can't begin with a string");
[macro_token] MODIFY_FLUSH(0,3,"PARSER ERROR, MACRO TOKEN FOUND");
[metric_token] IF DIM_PTR=NULL_RECORD
THEN α DIM_PTR←TOKEN_PTR; GET_TOKEN; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH(0,56,"AMBIGUOUS DIMENSIONS");
[procedure_token]
α reject←true; p_exp2; print("("&labl&" " &outexpr[2 to ∞ - 1]&")"); β;
[id_token] IF DIM_PTR = NULL_RECORD
THEN
α
IF BLOCK_LEVEL_OF_DEFN≠0 OR TOKEN_EQU("BARM","YARM","BHAND","YHAND")
THEN
CASE (ID_TYPE + 3)OF
α
[LABEL_VALUE +3]
α LABEL_TYPE←ID_TYPE;
IF DEFINED(TOKEN_PTR) THEN ERROR(22,"Label multiply used.");
DEFIN(TOKEN_PTR);
IF EQU(LABL,null) THEN LABL←TOKEN&" " ELSE ERROR(22,"Double label.");
check_next_token(23, NULL ,":");
GET_TOKEN; GO TO TRY_AGAIN;
β;
[form_value +3]
[boole_VALUE +3]
[SCALAR_VALUE +3]
[VECTOR_VALUE +3]
[ROT_VALUE +3]
[FRAME_VALUE +3]
[PLANE_VALUE +3]
[TRANS_VALUE +3]
α STRING ID, AS; RPTR(DIMENS_EXPONENT) ID_DIMEN;INTEGER ID_T,BL;
RPTR(ID_LIST) R1; R1←TOKEN_PTR; BL←BLOCK_LEVEL_OF_DEFN;
ID←TOKEN; ID_T←ID_TYPE; ID_DIMEN←ID_LIST:DIMEN[TOKEN_PTR]; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS; GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS ";REJECT←TRUE;
IF ¬BL THEN F_STATE(0,7,"TRYING TO ASSIGN VALUE TO ARM OR DEVICE"); β
ELSE AS←"PAS ";
SS←"("&LABL&" $"&AS&id; P_EXP2;
IF EXP_TYPE=0 THEN OUTEXPR← "( )" ELSE
IF ¬CHECK_EXP_TYPE_DIMENS(ID_T,ID_DIMEN,"assignment statement")
THEN ERROR(121,"Type mismatch on assignment.");
DEFIN(R1); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN α REJECT←TRUE; TEMP←FALSE;PRINT("("&LABL&" $"&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")"); β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("($CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&" $"&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH(0,0,"Can't start this way")
β;
β;
[string_VALUE +3]
F_STATE(0,2,"Statement can't begin with a string");
ELSE F_STATE(0,4,"Statement can't begin this way")
β
ELSE MODIFY_FLUSH(0,7,"Assignment statement can't begin with predefined constant");
β
ELSE ERROR(25, "CANNOT HAVE DIMENSION IN FRONT OF VARIABLE");
[array_token] IF DIM_PTR = NULL_RECORD
THEN
α INTEGER ARRAY_T; RPTR(DIMENS_EXPONENT)ARRAY_D;
STRING AS;
ARRAY_T←ARRAY_TYPE; ARRAY_D←ARRAY_LIST:DIMEN[TOKEN_PTR];
REJECT←TRUE;
P_EXP2;
GET_TOKEN;
IF TOKEN = "←" THEN
α STRING SS; GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS ";REJECT←TRUE;
β
ELSE AS←"PAS ";
SS←"("&LABL&" $"&AS&outexpr; P_EXP2;
IF EXP_TYPE=0 THEN OUTEXPR← "( )" ELSE
IF ¬CHECK_EXP_TYPE_DIMENS(array_T,array_D,"assignment statement")
THEN ERROR(121,"Type mismatch on assignment.");
! DEFIN(R1); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β
ELSE ERROR(122, "need ← here ");
β
ELSE ERROR(25, "CANNOT HAVE DIMENSION IN FRONT OF VARIABLE");
[undeclared_token]
α STRING ID, AS; INTEGER ID_T;RPTR(DIMENS_EXPONENT) ID_DIMEN;
RPTR(ID_LIST) POINT; ID←TOKEN; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS;GET_TOKEN;
IF ¬EQU(TOKEN,"←")THEN α AS←"AS "; REJECT←TRUE; β ELSE α AS←"PAS "; β;
SS←"("&LABL&"$"&AS&id; P_EXP2;
IF MODIFY_CONTINUE(0,"Undefined variable "&id&crlf&
"Continue will declare it . Modify will allow correction.")
THEN GOTO TRY_AGAIN
ELSE
α POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←EXP_TYPE; ID_LIST:DIMEN[POINT]←EXP_DIMENS;
IF EXP_TYPE=Trans_VALUE THEN ID_T←frame_VALUE ELSE ID_T←EXP_TYPE;
PRINT("("&DEC_NAME[ID_T]&" "&ID&")");
DEFIN(POINT); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
RPTR(ID_LIST) POINT; POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←trans_VALUE; DEFIN(POINT);
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN
α REJECT←TRUE; TEMP←FALSE;
PRINT("("&LABL&"$GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")");
β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("($CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&"$GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH(0,25,"Can't start statement this way with undeclared variable")
β;
β;
[reserved_token]
α INSIDE_STATEMENT←RESERVED_TOKEN_PTR;
IF (statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end)
THEN CASE TYPE_OF_RES_WORD - statement_beg OF
α
redefine xx(str)=[redefine xx_temp="str" & "_P"; xx_temp;];
redefine yy(str)=[];
redefine zz(str)=[redefine zz_temp="str" & "_P"; zz_temp;];
statement_definitions;
β
ELSE IF TOKEN_PTR←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE)
THEN α TYPE_OF_TOKEN←METRIC_TOKEN;
DIM_PTR←TOKEN_PTR; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH(0,3,"Statement can't begin with <"&TOKEN&">");
β
β;
FLUSH:
β "P_STATEMENT";
! execution starts here, initialization;
procedure update_break_RS;
α
ifc full_set thenc
SETBREAK(word_R_break, TABLE1, NULL, "INRF");
SETBREAK(word_S_break, TABLE1, NULL, "INSF");
elsec
SETBREAK(word_R_break, TABLE1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1, NULL, "INSK");
endc
β;
α "execution"
RUNTIME←___TIME;
INITIALIZE←TRUE;
COUNT ← 1000; DELIMITER_1 ← "⊂"; DELIMITER_2 ← "⊃";
OPEN_BRACE← "{" ;
TABLE1 ← "⊂⊃%,.;:[](){}+-*/#∧∨¬⊗&≤≥<>≠=←↑→?|" & lf & cr & dquote & tab & ff & space & squote ;
ifc full_set thenc
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRF");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRF");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSF");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRF");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISF");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAF");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANF");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANF");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANF");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRF");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
SETBREAK(
tty_input_break ← getbreak,ALT,NULL,"IS");
SETBREAK(
knvrt_break ← getbreak,NULL,NULL,"IK");
SETBREAK(
macro_delimiter_break ← getbreak,"⊂⊃",NULL,"IS");
elsec
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRK");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRK");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSK");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRK");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISK");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAK");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANK");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANK");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANK");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRK");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
SETBREAK(
tty_input_break ← getbreak,ALT,NULL,"IS");
SETBREAK(
macro_delimiter_break ← getbreak,"⊂⊃",NULL,"IS");
TTYUP(TRUE);
endc
WANT_DUP_FILE←TRUE;
! set up input and output;
if rpgsw then
α
cmd_line ← tmpin("AL", eof);
if eof
then α usererr(0, 1, "TMPIN lost"); rpgsw ← false β
else outstr(crlf & "AL: ");
β;
if ¬rpgsw then α outstr(crlf & "*"); cmd_line ← instrl(cr) β;
BIN_file ← new_record(file); ALL_file ← new_record(file);
SEX_file ← new_record(file); T←TRUE;
while true do
α "command" define want_BAIL=[switch_setting[b_X]];
want_BAIL ← false;
if ¬T then α outstr(crlf & "*"); cmd_line ← instrl(cr) β; T ← false;
PRESENT_file←AL_file ← scan_command(cmd_line, BIN_file, ALL_file);
if file:eof[AL_file] then
α usererr(0, 1, "null input spec"); continue "command" β;
file:mode[AL_file] ← 0; file:in_bfrs[AL_file] ← 12; file:out_bfrs[AL_file] ← 0;
file:def_ext[AL_file] ← "AL";
if ¬got_input(AL_file) then
α outstr(infile & "file not found"); continue "command" β;
if file:name[BIN_file]=null
then if file:name[AL_file]= null
then file:name[BIN_file]←"ALMAIN"
else file:name[BIN_file]←file:name[AL_file];
copy_file_record(SEX_file, BIN_file);
file:mode[SEX_file] ← 0; file:in_bfrs[SEX_file] ← 0;
file:out_bfrs[SEX_file] ← 12; file:ext[SEX_file] ← "SEX";
if file:eof[SEX_file] then
α "null output spec"
file:device[SEX_file] ← "DSK";
if file:name[AL_file]≠null
then file:name[SEX_file] ← file:name[AL_file]
else file:name[SEX_file] ← "ALMAIN" ;
β "null output spec";
if ¬got_output(SEX_file) then
α usererr(0, 1, "can't get output"); continue "command" β;
outfile←make_file_name(SEX_file);
chanin ← file:chn[AL_file]; chanout ← file:chn[SEX_file];
if equ(file:device[PRESENT_file],"TTY")
then
α
now_top_file←true;
CHECK_WANT_COPY;
now_top_file←false;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
CHANTTYO←-1;
β;
pagenum ← linenum ← sourcelvl ← 0;
typed_page_num ← true;
ifc debug_compile thenc if want_BAIL then BAIL; endc
done "command"
β "command";
ifc dup_file thenc
OPEN_NEW_AL_FILE(BIN_FILE, "NEW");
endc
GET_TOKEN;
IF EQU(CURLINE[1 TO 17],"COMMENT ⊗ VALID")
THEN α GARB←READ(SEMICOLON_A_BREAK); get_token; β;
PARSED_STRING←null; curliner←curline;
! set up predefined dimensions, constants, macros and variables;
redefine zz(temp)=[];
redefine yy(temp,temp2)=[
redefine xx_temp= "DIMENS_EXPONENT:"&"temp"&"["&"temp"&"_DIMENS]←1;";
qq(temp)
xx_temp];
redefine qq(temp)=[redefine xxcount=xxcount+1;
redefine yytemp= "temp"&"_DIMENS←NEW_RECORD(DIMENS_EXPONENT);";
redefine zztemp= "DIMENS_EXPONENT:NAME["&"temp"&"_DIMENS]←"&""""&"temp"&""""&";";
redefine xxtemp(xxxcount)=
"D_TABLE["&"xxxcount" & "] ← INSERT_ENTRY("&""""&"temp"
&""""&",DIMENSION_TYPE_TABLE,"&"temp"&"_DIMENS);";
yytemp
zztemp
xxtemp(xxcount)];
redefine xxcount=-1;
metric_definitions;
INSERT_ENTRY("DIMENSIONLESS",DIMENSION_TYPE_TABLE);
VELOCITY_DIMENS←DIVIDE_DIMENSIONS(DISTANCE_DIMENS,TIME_DIMENS);
TORQUE_DIMENS ← MULTIPLY_DIMENSIONS(FORCE_DIMENS,DISTANCE_DIMENS);
ANGULAR_VELOCITY_DIMENS←DIVIDE_DIMENSIONS(ANGLE_DIMENS,TIME_DIMENS);
FOR I←1 STEP 1 UNTIL const_count DO
α RPTR (ID_LIST) TEMP;
INSERT_ENTRY(PRECONST[I],ID_TYPE_TABLE,TEMP←NEW_RECORD(ID_LIST));
ID_LIST:TYPE[TEMP]←PRECONST_TYPE[I];
ID_LIST:DIMEN[TEMP]←D_TABLE[PRE_DIMENS[I]];
DEFIN(TEMP);
β;
ID_LIST:BODY[CHECK_ENTRY("CRLF",ID_TYPE_TABLE)]← "
";
redefine xx(str1, str2)=[
MACRO_LIST:VALUE[cur_macro←INSERT_ENTRY("str1",MACRO_TYPE_TABLE)]←"str2";
cur_macro←null_record;
];
macro_definitions;
INITIALIZE←FALSE;
! PARSE PROGRAM;
spacing ← 0; print("($PR"); SPACING ← SAVSPACING←1; BLOCK_LEVEL←0;
PRINTOUT;
! **********; P_STATEMENT; ! **********;
IF TOP_SOURCE≠NULL_RECORD OR ¬EQU(INPUT(CHANIN,omit_break),null) THEN
ERROR(200,"Misc. garbage found after last end.");
spacing ← 0; print(")"); printout;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
if chanin > -1 then α out(channew,curliner);
while ¬eof do out(channew,input(chanin,0)); β;
endc
! CLEAN UP;
IF CHANIN>-1 THEN RELEASE(CHANIN);
WHILE TOP_SOURCE≠NULL DO
α
IF SOURCE_LIST:CHAN[TOP_SOURCE]>-1
THEN α out(channew, curliner); while ¬eof do out(channew,input(chanin,0));
RELEASE(SOURCE_LIST:CHAN[TOP_SOURCE]); β;
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β;
CLOSO(CHANOUT);
CLOSO(CHANLOG);
IF CHANTTYO>-1 THEN CLOSO(CHANTTYO);
ifc dup_file thenc
IF WANT_DUP_FILE AND (NUM_OF_ERRORS_MODIFIED>0)
THEN IF ASK_WANT_DUP_FILE THEN CLOSO(CHANNEW);
endc
RUNTIME←___TIME - RUNTIME;
OUTSTR(CRLF & "PARSING TIME = "&CVS(RUNTIME)& " MSECS");
IF NUM_OF_ERRORS > 0 THEN
α
OUTSTR(crlf & "Number of errors found = "& cvs(NUM_OF_ERRORS));
OUTSTR(CRLF & "Number of errors modified = "& cvs(NUM_OF_ERRORS_MODIFIED));
β;
β "execution";
! SWAP TO AL COMPILER;
α "swap" integer array swap[0:10]; string s; integer tmperr;
if length(file:ext[BIN_file])=0 then file:ext[BIN_file] ← "BIN";
s ← make_file_name(BIN_file) & "," & make_file_name(ALL_file) & "←" & outfile;
α "switches_for_ALC" boolean seen_one; integer i;
seen_one ← false;
for i ← 0 step 1 until switch_max do
if switch_setting[i] then
α
if ¬seen_one then α s ← s & "("; seen_one ← true β;
s ← s & switch_name[i];
β;
if ¬equ(switch_name[switch_max+1],NULL) then
if seen_one then s←s&switch_name[switch_max+1]
else s←s& "(" &switch_name[switch_max+1]&")";
if seen_one then s ← s & ")";
β "switches_for_ALC";
! if switch_setting[N_X] then tmpout("ALCNEW", s, tmperr) else tmpout("ALC", s, tmperr);
tmpout("ALC", s, tmperr);
if tmperr then usererr(0, 1, "Trouble with TMPOUT");
outstr(crlf);
swap[0] ← cvsix("DSK");
if switch_setting[N_X]
then swap[1] ← cvfil("ALCNEW.DMP[AL,HE]", swap[2], swap[4])
else swap[1] ← cvfil("ALC.DMP[AL,HE]", swap[2], swap[4]);
swap[3] ← 1; ! start job in RPG mode; swap[5] ← 0;
call(location(swap[0]), "SWAP");
β "swap";
IFC FALSE THENC
β "hidden_parse";
HIDDEN_PARSE;
ENDC
END "PARSE";